Aero Glass

From Free Pascal wiki
Jump to navigationJump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Windows logo - 2012.svg

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

aero glass lazarus.png

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

aeroglasswin10.png 

{
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):

Retrieved from "http://wiki.freepascal.org/index.php?title=Aero_Glass&oldid=137396"