v1.3.3 EnableBlur for Windows.

Now, InFrame window has a nice border and shadow with a blur effect.
torum · Jan 9, 2023 · 4da59fd · 4da59fd
1 parent 7749730
commit 4da59fd
Show file tree

Hide file tree

Showing 4 changed files with 156 additions and 41 deletions.
diff --git a/.gitignore b/.gitignore
@@ -30,3 +30,5 @@ backup/ufullscreen.pas
 backup/ufullscreen.lfm
 ImageViewer.app/Contents/Info.plist
 ImageViewer.app/Contents/PkgInfo
+backup/
+
diff --git a/uabout.lfm b/uabout.lfm
@@ -1,20 +1,19 @@
 object frmAbout: TfrmAbout
-  Left = 1157
-  Height = 293
-  Top = 606
-  Width = 400
+  Left = 1707
+  Height = 234
+  Top = 849
+  Width = 320
   BorderStyle = bsToolWindow
-  ClientHeight = 293
-  ClientWidth = 400
-  DesignTimePPI = 120
+  ClientHeight = 234
+  ClientWidth = 320
   OnClose = FormClose
   Position = poOwnerFormCenter
-  LCLVersion = '1.8.4.0'
+  LCLVersion = '2.2.2.0'
   object Image1: TImage
-    Left = 24
-    Height = 113
-    Top = 24
-    Width = 113
+    Left = 19
+    Height = 90
+    Top = 19
+    Width = 90
     Picture.Data = {
       1754506F727461626C654E6574776F726B477261706869637A39000089504E47
       0D0A1A0A0000000D49484452000001F4000001F40806000000CBD6DF8A000000
@@ -481,57 +480,57 @@ object frmAbout: TfrmAbout
     Proportional = True
   end
   object StaticTextAppsVer: TStaticText
-    Left = 168
-    Height = 21
-    Top = 72
-    Width = 121
+    Left = 134
+    Height = 16
+    Top = 58
+    Width = 95
     AutoSize = True
     Caption = 'StaticTextAppsVer'
     TabOrder = 0
   end
   object StaticTextWho: TStaticText
-    Left = 256
-    Height = 21
-    Top = 104
-    Width = 96
+    Left = 205
+    Height = 16
+    Top = 83
+    Width = 76
     AutoSize = True
     Caption = 'StaticTextWho'
     TabOrder = 1
   end
   object StaticTextWebSite: TStaticText
-    Left = 32
-    Height = 21
-    Top = 180
-    Width = 351
+    Left = 26
+    Height = 17
+    Top = 144
+    Width = 281
     Caption = 'https://torum.github.io/Image-viewer/'
     OnClick = StaticTextWebSiteClick
     OnMouseEnter = StaticTextWebSiteMouseEnter
     OnMouseLeave = StaticTextWebSiteMouseLeave
     TabOrder = 2
   end
   object LabelWebsite: TLabel
-    Left = 32
-    Height = 20
-    Top = 152
-    Width = 56
+    Left = 26
+    Height = 15
+    Top = 122
+    Width = 45
     Caption = 'Website:'
     ParentColor = False
   end
   object ButtonClose: TButton
-    Left = 280
-    Height = 31
-    Top = 240
-    Width = 94
+    Left = 224
+    Height = 25
+    Top = 192
+    Width = 75
     Caption = 'Close'
     Default = True
     ModalResult = 1
     OnClick = ButtonCloseClick
     TabOrder = 3
   end
   object Bevel1: TBevel
-    Left = 24
-    Height = 7
-    Top = 216
-    Width = 351
+    Left = 19
+    Height = 6
+    Top = 173
+    Width = 281
   end
 end
diff --git a/umain.lfm b/umain.lfm
@@ -5,7 +5,6 @@ object frmMain: TfrmMain
   Width = 320
   AllowDropFiles = True
   AlphaBlend = True
-  AlphaBlendValue = 20
   Caption = 'Image Viewer Main'
   ClientHeight = 241
   ClientWidth = 320

diff --git a/umain.pas b/umain.pas
@@ -1,6 +1,7 @@
 unit UMain;
 
-{$mode objfpc}{$H+}
+{$mode delphi}
+// {$mode objfpc}{$H+}
 
 {
 Source:
@@ -41,7 +42,7 @@ interface
 uses
   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
   LclType, LclProc, LclIntf, Menus, StdCtrls, ExtDlgs,
-  strutils, Types, FileCtrl, XMLConf{$ifdef windows}, windirs, Windows{$endif};
+  strutils, Types, FileCtrl, XMLConf{$ifdef windows}, windirs, Windows, DWMApi{$endif};
 
 type
 
@@ -170,6 +171,10 @@   TfrmMain = class(TForm)
     procedure DrawImage;
     procedure LoadDirectories(const Dirs: TStringList; FList: TStringList);
     procedure LoadSiblings(const FName: string; FList: TStringList);
+    {$ifdef windows}
+    procedure EnableBlur;
+    //procedure AeroGlass;
+    {$endif}
   public
     property FileList: TStringList read FstFileList;
     // User options. Read/Write.
@@ -198,9 +203,29 @@   TfrmMain = class(TForm)
     procedure SetCaption(strCaption:string);
   end;
 
+  {$ifdef windows}
+  AccentPolicy = packed record
+    AccentState: Integer;
+    AccentFlags: Integer;
+    GradientColor: Integer;
+    AnimationId: Integer;
+  end;
+
+  TWinCompAttrData = packed record
+    attribute: THandle;
+    pData: Pointer;
+    dataSize: ULONG;
+  end;
+  {$endif}
+
 var
   frmMain: TfrmMain;
 
+{$ifdef windows}
+var
+  SetWindowCompositionAttribute: function (Wnd: HWND; const AttrData: TWinCompAttrData): BOOL; stdcall = Nil;
+{$endif}
+
 resourcestring
   resstrStretch = 'Stretch';
   resstrStretchIn = 'In (big->screen)';
@@ -353,7 +378,7 @@ procedure TfrmMain.FormCreate(Sender: TObject);
   i,f:integer;
   configFile:string;
 begin
-  FstrAppVer:='1.3.2';
+  FstrAppVer:='1.3.3';
 
   // Init Main form properties.
   self.Caption:=ReplaceStr(ExtractFileName(ParamStr(0)),ExtractFileExt(ParamStr(0)),'');
@@ -1492,6 +1517,7 @@ procedure TfrmMain.MenuItemSlideshowInFrameClick(Sender: TObject);
 {$ifdef windows}
 var
   titlebarheight:integer;
+  //rgn:Cardinal;
 {$else}
 var
   Form: TForm;
@@ -1523,6 +1549,15 @@ procedure TfrmMain.MenuItemSlideshowInFrameClick(Sender: TObject);
     self.left := self.left + GetSystemMetrics(SM_CYFRAME); // added in v1.2.18
     titlebarheight:=GetSystemMetrics(SM_CYCAPTION)+ GetSystemMetrics(SM_CYFRAME);
     self.height := self.height + titlebarheight;
+
+    // Rounded corner window on per with Windows11.
+    //rgn:=CreateRoundRectRgn(0,0,self.width,self.height,16,16);
+    //SetWindowRgn(Handle,Rgn,True);
+
+    // Could be better?
+    DoubleBuffered := True;
+    EnableBlur;
+
     {$else}
       // https://forum.lazarus.freepascal.org/index.php?topic=38675.0
       FOrigBounds:= BoundsRect;
@@ -1575,7 +1610,6 @@ procedure TfrmMain.DoneInFrame(strCurr :string);
   BoundsRect:= FOrigBounds;
   self.BorderStyle:=bsSizeable;
   BoundsRect:=FOrigBounds;
-
   if (self.top < 0) then self.top := 0;
   if (self.left < -100) then self.left := 0;
 
@@ -1997,6 +2031,7 @@ procedure TfrmMain.SetFullScreen_Universal(blnOn: boolean);
     // Don't do this at runtime on linux!
     // https://forum.lazarus.freepascal.org/index.php?topic=38675.0
     BorderStyle:= bsNone;
+
     {$endif}
 
     {$ifdef darwin}
@@ -2077,6 +2112,12 @@ procedure TfrmMain.SetFullScreen_Win32(blnOn: boolean);
       BoundsRect:= CurrentMonitor.BoundsRect;
     end;
 
+    {$ifdef windows}
+    // Not really good?
+    //DoubleBuffered := True;
+    //EnableBlur;
+    {$endif}
+
     // ShowWindow(Handle, SW_SHOWFULLSCREEN);
   end else
   begin
@@ -2145,7 +2186,81 @@ procedure TfrmMain.StoreFormState;
 
 end;
 
+{$ifdef windows}
+// https://wiki.lazarus.freepascal.org/Aero_Glass
+procedure TfrmMain.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.GradientColor := ($000000FF);
+
+      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 TfrmMain.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;
+*)
+
+initialization
+  SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute');
+{$endif}
 end.