Aero Glass: what changed

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