Sign in Join
Wiki copytemporary

Aero Glass: what changed

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

Title: Aero Glass

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;
22+
23+type
24+ _MARGINS = packed record
25+ cxLeftWidth : Integer;
26+ cxRightWidth : Integer;
27+ cyTopHeight : Integer;
28+ cyBottomHeight : Integer;
29+ end;
30+
31+ PMargins = ^_MARGINS;
32+ TMargins = _MARGINS;
33+
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;
37+
38+const
39+ WS_EX_LAYERED = $80000;
40+ LWA_COLORKEY = 1;
41+
42+procedure GlassForm(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia);
43+function WindowsAeroGlassCompatible: Boolean;
44+
45+implementation
46+
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;
61+
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 }
81+ if (
82+ (@fDwmIsCompositionEnabled <> nil) and
83+ (@fDwmExtendFrameIntoClientArea <> nil) and
84+ (@fSetLayeredWindowAttributesFunc <> nil)
85+ )
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);
104+ end;
105+ end;
106+ { Free loaded 'dwmapi' library }
107+ FreeLibrary(hDWMDLL);
108+ end;
109+ end;
110+end;
111+
112+end.
113+```
114+
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":
121+
122+``` pascal
123+unit 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
132+```
133+
134+OnActivate event of each form call the procedure in this way:
135+
136+``` pascal
137+procedure 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;
149+```
150+
151+Also you need to enable Themes to use this procedure, go to Options \> Project Options \> then select "Use Manifest to Enable Themes (Windows)".
152+
153+## Windows 10
154+
155+<figure>
156+<img src="aeroglasswin10.png" title="aeroglasswin10.png" />
157+<figcaption>aeroglasswin10.png</figcaption>
158+</figure>
159+
160+``` pascal
161+{
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;
251+ end;
252+ Picture.Assign(IM);
253+
254+ finally
255+ IM.Free;
256+
257+ 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
284+ 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');
314+ try
315+ @SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute');
316+ if @SetWindowCompositionAttribute <> nil then
317+ 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);
327+ end
328+ else
329+ begin
330+ ShowMessage('Not found Windows 10 blur API');
331+ end;
332+ finally
333+ FreeLibrary(dwm10);
334+ 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
369+ Result := False;
370+ 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
391+ Result := False;
392+ 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.
449+```
450+
451+## Bugs
452+
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":
454+
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)
457+
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).
459+
460+## About
461+
462+This was converted to Lazarus using "{\$mode delphi}" from "Aero Glass Effekt für Delphi-Forms, Delphi-Unit von Daniel Mitte (2006)":
463+
464+- [Aero Glass Effekt für Delphi-Forms](http://www.delphipraxis.net/74538-aero-glass-effekt-fuer-delphi-forms.html)
465+
466+There is a Delphi component here (to be ported in Lazarus):
467+
468+- [D. Mitte in Torry's Delphi Page](http://www.torry.net/authorsmore.php?id=6179)
469+
470+---
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

Back to history