Aero Glass: what changed

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

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