Aero Glass/pl

Ten artykuł odnosi się tylko do Windows.

Zobacz także: Przewodnik programowania wieloplatformowego

│ Deutsch (de) │ English (en) │ español (es) │ polski (pl) │

Efekt szkła (Aero Glass) na formularzu Lazarusa

Na początku zapisz plik ,,glass.pas", zawierający poniższy kod:

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.

Następnie skopiuj moduł ,,glass.pas" do katalogu głównego Twojej aplikacji (tu: MojProjekt):

 MojProjekt\glass.pas
 

W sekcji ,,uses" w module głównym aplikacji (tu: form1) dopisz frazę ,,glass":

unit form1;
  
{$mode objfpc}{$H+}
  
interface
  
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs
  glass; // Tu zawiera się procedura GlassForm

Utwórz na formularzu zdarzenie OnActivate i uzupełnij je, tak jak poniżej:

procedure TForm1.FormActivate(Sender: TObject);
var
  tmpMargins: TMargins;
begin
  { Jeżeli marginesy mają wartość -1, to cała forma będzie pokryta szkłem }
  tmpMargins.cxLeftWidth    := -1;
  tmpMargins.cxRightWidth   := -1;
  tmpMargins.cyBottomHeight := -1;
  tmpMargins.cyTopHeight    := -1;
  { FormName ; Margins ; TransparentColor }
  GlassForm(Self, tmpMargins, clFuchsia); 
end;

WAŻNE: Przed uruchomieniem aplikacji włącz kompozycje, wchodząc w Projekt > Opcje projektu > zaznacz opcję ,,Użyj pliku manifest aby odblokować kompozycje".

Bugi

Po włączeniu szkła wyraźnie widać, iż napisy (TLabel) nie mają tzw. ,,otoczki szkła"; aby to rozwiązać, poniżej znajdują się linki do komponentów zwanych ,,Glow Labels":

• GlowLabel for Delphi
• Aero Glass - ein Text (Label) hintergrund "machen"

Jeżeli ustawisz kolor części systemowych (np. kolor okna), to kliknięcie na formularz będzie niemożliwe(forma traci fokus przez szkło).

Informacje

Powyższe kody zostały przekonwertowane do Lazarusa używając "{$mode delphi}" z "Aero Glass Effekt für Delphi-Forms, Delphi-Unit von Daniel Mitte (2006)":

• Aero Glass Effekt für Delphi-Forms

Tu znajduje się komponent (przekonwertowany także do Lazarusa):

• D. Mitte in Torry's Delphi Page