Sign in Join
Wiki copytemporary

Aero Glass: what changed

Revision 1 to 2. Removed lines have a minus sign; added lines have a plus sign.

OldNewLine
1-*(Windows only)*
2-
3-## Aero Glass effect on Lazarus Form
4-
5-<figure>
6-<img src="aero_glass_lazarus.png" title="aero_glass_lazarus.png" />
7-<figcaption>aero_glass_lazarus.png</figcaption>
8-</figure>
9-
10-First save the above code to a text file "glass.pas":
11-
12-``` pascal
13-unit glass;
14-
15-{$mode delphi}
16-//{$mode objfpc}{$H+}
17-
18-interface
19-
20-uses
21- Windows, Forms, Graphics;
1+[![Windows logo - 2012.svg](https://upload.wikimedia.org/wikipedia/commons/thumb/5/5f/Windows_logo_-_2012.svg/50px-Windows_logo_-_2012.svg.png)](</File:Windows_logo_-_2012.svg>)
222
23-type
24- _MARGINS = packed record
25- cxLeftWidth : Integer;
26- cxRightWidth : Integer;
27- cyTopHeight : Integer;
28- cyBottomHeight : Integer;
29- end;
3+This article applies to [Windows](</Category:Windows> "Category:Windows") only.
304
31- PMargins = ^_MARGINS;
32- TMargins = _MARGINS;
5+See also: [[Multiplatform Programming Guide]]
336
34- DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall;
35- DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall;
36- SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall;
7+│ **[[Aero Glass/de|Deutsch (de)]]** │ **English (en)** │ **[[Aero Glass/es|español (es)]]** │ **[[Aero Glass/pl|polski (pl)]]** │
8+****
379
38-const
39- WS_EX_LAYERED = $80000;
40- LWA_COLORKEY = 1;
10+## Contents
4111
42-procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
43-function WindowsAeroGlassCompatible: Boolean;
12+ * 1 Aero Glass effect on Lazarus Form
13+ * 2 Windows 10
14+ * 3 Bugs
15+ * 4 About
4416
45-implementation
17+## Aero Glass effect on Lazarus Form
4618
47-function WindowsAeroGlassCompatible: Boolean;
48-var
49- osVinfo: TOSVERSIONINFO;
50-begin
51- ZeroMemory(@osVinfo, SizeOf(osVinfo));
52- OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
53- if (
54- (GetVersionEx(osVInfo) = True) and
55- (osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
56- (osVinfo.dwMajorVersion >= 6)
57- )
58- then Result:=True
59- else Result:=False;
60-end;
19+[![aero glass lazarus.png](/wiki-images/8/83/aero_glass_lazarus.png)](</File:aero_glass_lazarus.png>)
6120
62-procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
63-var
64- hDwmDLL: Cardinal;
65- fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc;
66- fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc;
67- fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc;
68- bCmpEnable: Boolean;
69- mgn: TMargins;
70-begin
71- { Continue if Windows version is compatible }
72- if WindowsAeroGlassCompatible then begin
73- { Continue if 'dwmapi' library is loaded }
74- hDwmDLL := LoadLibrary('dwmapi.dll');
75- if hDwmDLL <> 0 then begin
76- { Get values }
77- @fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled');
78- @fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea');
79- @fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
80- { Continue if values are <> nil }
21+First save the above code to a text file "glass.pas":
22+```
23+unit glass;
24+
25+ {$mode delphi}
26+ //{$mode objfpc}{$H+}
27+
28+ interface
29+
30+ uses
31+ Windows, Forms, Graphics;
32+
33+ type
34+ _MARGINS = packed record
35+ cxLeftWidth : Integer;
36+ cxRightWidth : Integer;
37+ cyTopHeight : Integer;
38+ cyBottomHeight : Integer;
39+ end;
40+
41+ PMargins = ^_MARGINS;
42+ TMargins = _MARGINS;
43+
44+ DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall;
45+ DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall;
46+ SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall;
47+
48+ const
49+ WS_EX_LAYERED = $80000;
50+ LWA_COLORKEY = 1;
51+
52+ procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
53+ function WindowsAeroGlassCompatible: Boolean;
54+
55+ implementation
56+
57+ function WindowsAeroGlassCompatible: Boolean;
58+ var
59+ osVinfo: TOSVERSIONINFO;
60+ begin
61+ ZeroMemory(@osVinfo, SizeOf(osVinfo));
62+ OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
8163 if (
82- (@fDwmIsCompositionEnabled <> nil) and
83- (@fDwmExtendFrameIntoClientArea <> nil) and
84- (@fSetLayeredWindowAttributesFunc <> nil)
64+ (GetVersionEx(osVInfo) = True) and
65+ (osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and
66+ (osVinfo.dwMajorVersion >= 6)
8567 )
86- then begin
87- { Continue if composition is enabled }
88- fDwmIsCompositionEnabled(@bCmpEnable);
89- if bCmpEnable = True then begin
90- { Set Form Color same as cBlurColorKey }
91- frm.Color := cBlurColorKey;
92- { ... }
93- SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
94- { ... }
95- fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY);
96- { Set margins }
97- ZeroMemory(@mgn, SizeOf(mgn));
98- mgn.cxLeftWidth := tmpMargins.cxLeftWidth;
99- mgn.cxRightWidth := tmpMargins.cxRightWidth;
100- mgn.cyTopHeight := tmpMargins.cyTopHeight;
101- mgn.cyBottomHeight := tmpMargins.cyBottomHeight;
102- { Extend Form }
103- fDwmExtendFrameIntoClientArea(frm.Handle,@mgn);
68+ then Result:=True
69+ else Result:=False;
70+ end;
71+
72+ procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
73+ var
74+ hDwmDLL: Cardinal;
75+ fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc;
76+ fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc;
77+ fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc;
78+ bCmpEnable: Boolean;
79+ mgn: TMargins;
80+ begin
81+ { Continue if Windows version is compatible }
82+ if WindowsAeroGlassCompatible then begin
83+ { Continue if 'dwmapi' library is loaded }
84+ hDwmDLL := LoadLibrary('dwmapi.dll');
85+ if hDwmDLL <> 0 then begin
86+ { Get values }
87+ @fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled');
88+ @fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea');
89+ @fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
90+ { Continue if values are <> nil }
91+ if (
92+ (@fDwmIsCompositionEnabled <> nil) and
93+ (@fDwmExtendFrameIntoClientArea <> nil) and
94+ (@fSetLayeredWindowAttributesFunc <> nil)
95+ )
96+ then begin
97+ { Continue if composition is enabled }
98+ fDwmIsCompositionEnabled(@bCmpEnable);
99+ if bCmpEnable = True then begin
100+ { Set Form Color same as cBlurColorKey }
101+ frm.Color := cBlurColorKey;
102+ { ... }
103+ SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
104+ { ... }
105+ fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY);
106+ { Set margins }
107+ ZeroMemory(@mgn, SizeOf(mgn));
108+ mgn.cxLeftWidth := tmpMargins.cxLeftWidth;
109+ mgn.cxRightWidth := tmpMargins.cxRightWidth;
110+ mgn.cyTopHeight := tmpMargins.cyTopHeight;
111+ mgn.cyBottomHeight := tmpMargins.cyBottomHeight;
112+ { Extend Form }
113+ fDwmExtendFrameIntoClientArea(frm.Handle,@mgn);
114+ end;
115+ end;
116+ { Free loaded 'dwmapi' library }
117+ FreeLibrary(hDWMDLL);
104118 end;
105119 end;
106- { Free loaded 'dwmapi' library }
107- FreeLibrary(hDWMDLL);
108120 end;
109- end;
110-end;
111-
112-end.
121+
122+ end.
113123```
114124
115-Copy the "glass.pas" file to the main folder of your project:
116-
117-` MyProject\glass.pas`\
118-` `
119-
120-In the "uses" section of your project you need to add "glass":
125+Copy the "glass.pas" file to the main folder of your project:
126+```
127+MyProject\glass.pas
128+```
121129
122-``` pascal
130+In the "uses" section of your project you need to add "glass":
131+```
123132unit form1;
124-
125-{$mode objfpc}{$H+}
126-
127-interface
128-
129-uses
130- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs
131- glass; // This includes GlassForm procedure
133+
134+ {$mode objfpc}{$H+}
135+
136+ interface
137+
138+ uses
139+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs
140+ glass; // This includes GlassForm procedure
132141```
133142
134-OnActivate event of each form call the procedure in this way:
135-
136-``` pascal
143+OnActivate event of each form call the procedure in this way:
144+```
137145procedure TForm1.FormActivate(Sender: TObject);
138-var
139- tmpMargins: TMargins;
140-begin
141- { If all margins are -1 the whole form will be aero glass}
142- tmpMargins.cxLeftWidth := -1;
143- tmpMargins.cxRightWidth := -1;
144- tmpMargins.cyBottomHeight := -1;
145- tmpMargins.cyTopHeight := -1;
146- { FormName ; Margins ; TransparentColor }
147- GlassForm(Self, tmpMargins, clFuchsia);
148-end;
146+ var
147+ tmpMargins: TMargins;
148+ begin
149+ { If all margins are -1 the whole form will be aero glass}
150+ tmpMargins.cxLeftWidth := -1;
151+ tmpMargins.cxRightWidth := -1;
152+ tmpMargins.cyBottomHeight := -1;
153+ tmpMargins.cyTopHeight := -1;
154+ { FormName ; Margins ; TransparentColor }
155+ GlassForm(Self, tmpMargins, clFuchsia);
156+ end;
149157```
150158
151-Also you need to enable Themes to use this procedure, go to Options \> Project Options \> then select "Use Manifest to Enable Themes (Windows)".
159+Also you need to enable Themes to use this procedure, go to Options > Project Options > then select "Use Manifest to Enable Themes (Windows)".
152160
153161## Windows 10
154162
155-<figure>
156-<img src="aeroglasswin10.png" title="aeroglasswin10.png" />
157-<figcaption>aeroglasswin10.png</figcaption>
158-</figure>
159-
160-``` pascal
163+[![aeroglasswin10.png](/wiki-images/8/84/aeroglasswin10.png)](</File:aeroglasswin10.png>)
164+```
161165{
162-author: vhanla
163-http://vhanla.codigobit.info
164-}
165-unit Unit1;
166-
167-interface
168-
169-uses
170- Windows, Messages, SysUtils, Variants, Classes, Graphics,
171- Controls, Forms, Dialogs, DWMApi, png, IntfGraphics, FPImage, GraphType,
172- StdCtrls, ExtCtrls, BCButtonFocus, BCLabel, Registry, LMessages, LCLType, LCLIntf;
173-
174-type
175-
176- { TForm1 }
177-
178- TForm1 = class(TForm)
179- BCButtonFocus1: TBCButtonFocus;
180- BCLabel1: TBCLabel;
181- Image1: TImage;
182- Image2: TImage;
183- Panel1: TPanel;
184-
185- procedure BCButtonFocus1Click(Sender: TObject);
186- procedure FormCreate(Sender: TObject);
187- procedure Button1Click(Sender: TObject);
188- procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
189- Shift: TShiftState; X, Y: Integer);
190- private
191- { Private declarations }
192- function TaskbarAccented:boolean;
193- function TaskbarTranslucent:boolean;
194- procedure EnableBlur;
195- procedure AeroGlass;
196- procedure UpdateColorization;
197- function GetAccentColor:TColor;
198- public
199- { Public declarations }
200- end;
201-
202- AccentPolicy = packed record
203- AccentState: Integer;
204- AccentFlags: Integer;
205- GradientColor: Integer;
206- AnimationId: Integer;
207- end;
208-
209- TWinCompAttrData = packed record
210- attribute: THandle;
211- pData: Pointer;
212- dataSize: ULONG;
213- end;
214-
215-var
216- Form1: TForm1;
217-
218-var
219- SetWindowCompositionAttribute: function (Wnd: HWND; const AttrData: TWinCompAttrData): BOOL; stdcall = Nil;
220-implementation
221-
222-{$R *.lfm}
223-
224-procedure SetAlphaColorPicture(
225- const Col: TColor;
226- const Alpha: Integer;
227- Picture: TPicture;
228- const _width: Integer;
229- const _height: Integer
230- );
231-var
232- IM: TLazIntfImage;
233- x,y: integer;
234- sl: pByteArray;
235- I, J, W, H: Integer;
236- FC: TFPColor;
237-begin
238- IM := TLazIntfImage.Create(0, 0, [riqfRGB, riqfAlpha]);
239- try
240- IM.SetSize(_width, _height);
241- for I := 0 to _width - 1 do
242- begin
243- for J := 0 to _height - 1 do
244- begin
245- FC.red := (128 + I) shl 8;
246- FC.green := (128 + J) shl 8;
247- FC.blue := 128 shl 8;
248- FC.alpha := 128 shl 8; // now works fine
249- IM.Colors[I, J] := FC;
250- end;
166+ author: vhanla
167+ http://vhanla.codigobit.info
168+ }
169+ unit Unit1;
170+
171+ interface
172+
173+ uses
174+ Windows, Messages, SysUtils, Variants, Classes, Graphics,
175+ Controls, Forms, Dialogs, DWMApi, png, IntfGraphics, FPImage, GraphType,
176+ StdCtrls, ExtCtrls, BCButtonFocus, BCLabel, Registry, LMessages, LCLType, LCLIntf;
177+
178+ type
179+
180+ { TForm1 }
181+
182+ TForm1 = class(TForm)
183+ BCButtonFocus1: TBCButtonFocus;
184+ BCLabel1: TBCLabel;
185+ Image1: TImage;
186+ Image2: TImage;
187+ Panel1: TPanel;
188+
189+ procedure BCButtonFocus1Click(Sender: TObject);
190+ procedure FormCreate(Sender: TObject);
191+ procedure Button1Click(Sender: TObject);
192+ procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
193+ Shift: TShiftState; X, Y: Integer);
194+ private
195+ { Private declarations }
196+ function TaskbarAccented:boolean;
197+ function TaskbarTranslucent:boolean;
198+ procedure EnableBlur;
199+ procedure AeroGlass;
200+ procedure UpdateColorization;
201+ function GetAccentColor:TColor;
202+ public
203+ { Public declarations }
251204 end;
252- Picture.Assign(IM);
253-
254- finally
255- IM.Free;
256-
205+
206+ AccentPolicy = packed record
207+ AccentState: Integer;
208+ AccentFlags: Integer;
209+ GradientColor: Integer;
210+ AnimationId: Integer;
211+ end;
212+
213+ TWinCompAttrData = packed record
214+ attribute: THandle;
215+ pData: Pointer;
216+ dataSize: ULONG;
217+ end;
218+
219+
220+ var
221+ Form1: TForm1;
222+
223+ var
224+ SetWindowCompositionAttribute: function (Wnd: HWND; const AttrData: TWinCompAttrData): BOOL; stdcall = Nil;
225+ implementation
226+
227+ {$R *.lfm}
228+
229+ procedure SetAlphaColorPicture(
230+ const Col: TColor;
231+ const Alpha: Integer;
232+ Picture: TPicture;
233+ const _width: Integer;
234+ const _height: Integer
235+ );
236+ var
237+ IM: TLazIntfImage;
238+ x,y: integer;
239+ sl: pByteArray;
240+ I, J, W, H: Integer;
241+ FC: TFPColor;
242+ begin
243+ IM := TLazIntfImage.Create(0, 0, [riqfRGB, riqfAlpha]);
244+ try
245+ IM.SetSize(_width, _height);
246+ for I := 0 to _width - 1 do
247+ begin
248+ for J := 0 to _height - 1 do
249+ begin
250+ FC.red := (128 + I) shl 8;
251+ FC.green := (128 + J) shl 8;
252+ FC.blue := 128 shl 8;
253+ FC.alpha := 128 shl 8; // now works fine
254+ IM.Colors[I, J] := FC;
255+ end;
256+ end;
257+ Picture.Assign(IM);
258+
259+
260+ finally
261+ IM.Free;
262+
263+ end;
257264 end;
258-end;
259-
260-procedure TForm1.Button1Click(Sender: TObject);
261-begin
262- Close;
263-end;
264-
265-procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
266- Shift: TShiftState; X, Y: Integer);
267-begin
268- ReleaseCapture;
269- SendMessage(Form1.Handle, LM_SYSCOMMAND, 61458, 0) ;
270-end;
271-
272-procedure TForm1.AeroGlass;
273-var
274- Aero: BOOL;
275- Area: TRect;
276- hDWM: THandle;
277-begin
278- hDWM:=LoadLibrary('dwmapi.dll');
279- try
280- @DwmIsCompositionEnabled:=GetProcAddress(hDWM,'DwmIsCompositionEnabled');
281- if @DwmIsCompositionEnabled<>nil then
282- DwmIsCompositionEnabled(Aero);
283- if Aero then
265+
266+ procedure TForm1.Button1Click(Sender: TObject);
284267 begin
285- Area:=Rect(-1,-1,-1,-1);
286- Color:=clBlack;
287- @DwmExtendFrameIntoClientArea:=GetProcAddress(hDWM,'DwmExtendFrameIntoClientArea');
288- if @DwmExtendFrameIntoClientArea<>nil then
289- DwmExtendFrameIntoClientArea(Handle,@Area);
290-
291- end
292- else ShowMessage('Aero is Disabled');
293- finally
294- FreeLibrary(hDWM);
295- end;
296-end;
297-
298-procedure TForm1.EnableBlur;
299-const
300- WCA_ACCENT_POLICY = 19;
301- ACCENT_ENABLE_BLURBEHIND = 3;
302- ACCENT_ENABLE_ACRYLICBLURBEHIND = 4;
303- DrawLeftBorder = $20;
304- DrawTopBorder = $40;
305- DrawRightBorder = $80;
306- DrawBottomBorder = $100;
307-var
308- dwm10: THandle;
309- data : TWinCompAttrData;
310- accent: AccentPolicy;
311-begin
312-
313- dwm10 := LoadLibrary('user32.dll');
268+ Close;
269+ end;
270+
271+ procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
272+ Shift: TShiftState; X, Y: Integer);
273+ begin
274+ ReleaseCapture;
275+ SendMessage(Form1.Handle, LM_SYSCOMMAND, 61458, 0) ;
276+ end;
277+
278+ procedure TForm1.AeroGlass;
279+ var
280+ Aero: BOOL;
281+ Area: TRect;
282+ hDWM: THandle;
283+ begin
284+ hDWM:=LoadLibrary('dwmapi.dll');
314285 try
315- @SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute');
316- if @SetWindowCompositionAttribute <> nil then
286+ @DwmIsCompositionEnabled:=GetProcAddress(hDWM,'DwmIsCompositionEnabled');
287+ if @DwmIsCompositionEnabled<>nil then
288+ DwmIsCompositionEnabled(Aero);
289+ if Aero then
317290 begin
318- accent.AccentState := ACCENT_ENABLE_BLURBEHIND ;
319- //accent.AccentState := ACCENT_ENABLE_ACRYLICBLURBEHIND;
320- accent.GradientColor := (100 SHL 24) or ($00E3E0DE);
321- accent.AccentFlags := DrawLeftBorder or DrawTopBorder or DrawRightBorder or DrawBottomBorder;
322-
323- data.Attribute := WCA_ACCENT_POLICY;
324- data.dataSize := SizeOf(accent);
325- data.pData := @accent;
326- SetWindowCompositionAttribute(self.Handle, data);
291+ Area:=Rect(-1,-1,-1,-1);
292+ Color:=clBlack;
293+ @DwmExtendFrameIntoClientArea:=GetProcAddress(hDWM,'DwmExtendFrameIntoClientArea');
294+ if @DwmExtendFrameIntoClientArea<>nil then
295+ DwmExtendFrameIntoClientArea(Handle,@Area);
296+
327297 end
328- else
329- begin
330- ShowMessage('Not found Windows 10 blur API');
331- end;
298+ else ShowMessage('Aero is Disabled');
332299 finally
333- FreeLibrary(dwm10);
300+ FreeLibrary(hDWM);
334301 end;
335-
336-end;
337-
338-procedure TForm1.FormCreate(Sender: TObject);
339-begin
340- DoubleBuffered := True;
341- Color := clBlack;
342- BorderStyle := bsnoNe;
343- BorderIcons := [biSystemMenu, biMinimize, biMaximize];
344- //AeroGlass;
345- if TaskbarTranslucent then
346- EnableBlur;
347-
348- UpdateColorization;
349-end;
350-
351-procedure TForm1.BCButtonFocus1Click(Sender: TObject);
352-begin
353- close;
354-end;
355-
356-function TForm1.TaskbarAccented: boolean;
357-var
358- reg: TRegistry;
359-begin
360- Result := False;
361- reg := TRegistry.Create;
362- try
363- reg.RootKey := HKEY_CURRENT_USER;
364- reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize');
365- try
366- if reg.ReadInteger('ColorPrevalence') = 1 then
367- Result := True;
368- except
302+ end;
303+
304+ procedure TForm1.EnableBlur;
305+ const
306+ WCA_ACCENT_POLICY = 19;
307+ ACCENT_ENABLE_BLURBEHIND = 3;
308+ ACCENT_ENABLE_ACRYLICBLURBEHIND = 4;
309+ DrawLeftBorder = $20;
310+ DrawTopBorder = $40;
311+ DrawRightBorder = $80;
312+ DrawBottomBorder = $100;
313+ var
314+ dwm10: THandle;
315+ data : TWinCompAttrData;
316+ accent: AccentPolicy;
317+ begin
318+
319+ dwm10 := LoadLibrary('user32.dll');
320+ try
321+ @SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute');
322+ if @SetWindowCompositionAttribute <> nil then
323+ begin
324+ accent.AccentState := ACCENT_ENABLE_BLURBEHIND ;
325+ //accent.AccentState := ACCENT_ENABLE_ACRYLICBLURBEHIND;
326+ accent.GradientColor := (100 SHL 24) or ($00E3E0DE);
327+ accent.AccentFlags := DrawLeftBorder or DrawTopBorder or DrawRightBorder or DrawBottomBorder;
328+
329+ data.Attribute := WCA_ACCENT_POLICY;
330+ data.dataSize := SizeOf(accent);
331+ data.pData := @accent;
332+ SetWindowCompositionAttribute(self.Handle, data);
333+ end
334+ else
335+ begin
336+ ShowMessage('Not found Windows 10 blur API');
337+ end;
338+ finally
339+ FreeLibrary(dwm10);
340+ end;
341+
342+ end;
343+
344+ procedure TForm1.FormCreate(Sender: TObject);
345+ begin
346+ DoubleBuffered := True;
347+ Color := clBlack;
348+ BorderStyle := bsnoNe;
349+ BorderIcons := [biSystemMenu, biMinimize, biMaximize];
350+ //AeroGlass;
351+ if TaskbarTranslucent then
352+ EnableBlur;
353+
354+ UpdateColorization;
355+ end;
356+
357+ procedure TForm1.BCButtonFocus1Click(Sender: TObject);
358+ begin
359+ close;
360+ end;
361+
362+ function TForm1.TaskbarAccented: boolean;
363+ var
364+ reg: TRegistry;
365+ begin
369366 Result := False;
367+ reg := TRegistry.Create;
368+ try
369+ reg.RootKey := HKEY_CURRENT_USER;
370+ reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize');
371+ try
372+ if reg.ReadInteger('ColorPrevalence') = 1 then
373+ Result := True;
374+ except
375+ Result := False;
376+ end;
377+ reg.CloseKey;
378+
379+ finally
380+ reg.Free;
381+ end;
370382 end;
371- reg.CloseKey;
372-
373- finally
374- reg.Free;
375- end;
376-end;
377-
378-function TForm1.TaskbarTranslucent: boolean;
379-var
380- reg: TRegistry;
381-begin
382- Result := False;
383- reg := TRegistry.Create;
384- try
385- reg.RootKey := HKEY_CURRENT_USER;
386- reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize');
387- try
388- if reg.ReadInteger('EnableTransparency') = 1 then
389- Result := True;
390- except
383+
384+ function TForm1.TaskbarTranslucent: boolean;
385+ var
386+ reg: TRegistry;
387+ begin
391388 Result := False;
389+ reg := TRegistry.Create;
390+ try
391+ reg.RootKey := HKEY_CURRENT_USER;
392+ reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\Themes\Personalize');
393+ try
394+ if reg.ReadInteger('EnableTransparency') = 1 then
395+ Result := True;
396+ except
397+ Result := False;
398+ end;
399+ reg.CloseKey;
400+
401+ finally
402+ reg.Free;
403+ end;
392404 end;
393- reg.CloseKey;
394-
395- finally
396- reg.Free;
397- end;
398-end;
399-
400-procedure TForm1.UpdateColorization;
401-begin
402- if TaskbarTranslucent then
403- begin
404- SetAlphaColorPicture(clblack, 200, Image1.Picture, 10,10 );
405- Image1.Align := alClient;
406- Image1.Stretch := True;
407- Image1.Visible := True;
408- end
409- else
410- Image1.Visible := False;
411-
412- if TaskbarAccented then
413- begin
414- SetAlphaColorPicture(9338482, 110, Image2.Picture, 10, 10);
415- Image2.Visible := True;
416- Image2.Align := alClient;
417- Image2.Stretch := True;
418- end
419- else
420- Image2.Visible := False;
421-end;
422-
423-function TForm1.GetAccentColor:TColor;
424-var
425- col: cardinal;
426- opaque: longbool;
427- newcolor: TColor;
428- a,r,g,b: byte;
429-begin
430- DwmGetColorizationColor(col, opaque);
431- a := Byte(col shr 24);
432- r := Byte(col shr 16);
433- g := Byte(col shr 8);
434- b := Byte(col);
435-
436- newcolor := RGB(
437- round(r*(a/255)+255-a),
438- round(g*(a/255)+255-a),
439- round(b*(a/255)+255-a)
440- );
441-
442- Result := newcolor;
443-
444-end;
445-
446-initialization
447- SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute');
448-end.
405+
406+
407+
408+ procedure TForm1.UpdateColorization;
409+ begin
410+ if TaskbarTranslucent then
411+ begin
412+ SetAlphaColorPicture(clblack, 200, Image1.Picture, 10,10 );
413+ Image1.Align := alClient;
414+ Image1.Stretch := True;
415+ Image1.Visible := True;
416+ end
417+ else
418+ Image1.Visible := False;
419+
420+ if TaskbarAccented then
421+ begin
422+ SetAlphaColorPicture(9338482, 110, Image2.Picture, 10, 10);
423+ Image2.Visible := True;
424+ Image2.Align := alClient;
425+ Image2.Stretch := True;
426+ end
427+ else
428+ Image2.Visible := False;
429+ end;
430+
431+ function TForm1.GetAccentColor:TColor;
432+ var
433+ col: cardinal;
434+ opaque: longbool;
435+ newcolor: TColor;
436+ a,r,g,b: byte;
437+ begin
438+ DwmGetColorizationColor(col, opaque);
439+ a := Byte(col shr 24);
440+ r := Byte(col shr 16);
441+ g := Byte(col shr 8);
442+ b := Byte(col);
443+
444+
445+ newcolor := RGB(
446+ round(r*(a/255)+255-a),
447+ round(g*(a/255)+255-a),
448+ round(b*(a/255)+255-a)
449+ );
450+
451+ Result := newcolor;
452+
453+
454+ end;
455+
456+
457+ initialization
458+ SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute');
459+ end.
449460```
450461
451462## Bugs
452463
453-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":
464+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":
454465
455-- [GlowLabel for Delphi](http://development.mwcs.de/glowlabel.html)
456-- [Aero Glass - ein Text (Label) hintergrund "machen"](http://www.delphipraxis.net/953968-post4.html)
466+ * [GlowLabel for Delphi](<http://development.mwcs.de/glowlabel.html>)
467+ * [Aero Glass - ein Text (Label) hintergrund "machen"](<http://www.delphipraxis.net/953968-post4.html>)
457468
458-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).
469+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).
459470
460471## About
461472
462-This was converted to Lazarus using "{\$mode delphi}" from "Aero Glass Effekt für Delphi-Forms, Delphi-Unit von Daniel Mitte (2006)":
473+This was converted to Lazarus using "{$mode delphi}" from "Aero Glass Effekt für Delphi-Forms, Delphi-Unit von Daniel Mitte (2006)":
463474
464-- [Aero Glass Effekt für Delphi-Forms](http://www.delphipraxis.net/74538-aero-glass-effekt-fuer-delphi-forms.html)
475+ * [Aero Glass Effekt für Delphi-Forms](<http://www.delphipraxis.net/74538-aero-glass-effekt-fuer-delphi-forms.html>)
465476
466-There is a Delphi component here (to be ported in Lazarus):
477+There is a Delphi component here (to be ported in Lazarus):
467478
468-- [D. Mitte in Torry's Delphi Page](http://www.torry.net/authorsmore.php?id=6179)
479+ * [D. Mitte in Torry's Delphi Page](<http://www.torry.net/authorsmore.php?id=6179>)
469480
470481---
471-*From the Free Pascal wiki, page "Aero Glass", as it stood on 2020-06-24 after a change by 007, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*
472-Category: Tutorials
473-Category: Windows
482+*From the Free Pascal wiki, page "Aero Glass", as the Internet Archive kept it on 2024-01-21. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*

Back to history