I have build my own system of menus based on a VBCCR toolbar. I use forms with BorderStyle=0 to popup my menus.
Now I have tested my program on a more recent version of Windows 11 and I lose the rounded corners and the blur shadow.
I have adapted my code for the rounded corners, but I can’t reproduce the Windows 11 shadow.
Has someone encountered the same problem ?
Here is the code I use :
Code:Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hWnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As Long, pMarInset As RECT) As Long Private Const DWMWA_WINDOW_CORNER_PREFERENCE = 33 Private Const DWMWCP_ROUND = 2 Public Sub ApplyRoundedCorners(frm As Object) ' If we are on Windows 11 and the build is < 26200, we don't need to apply this sub ' as ApplyWin11Effects() does the work. If IsWindows11 Then If WinVerBuild < 26200 Then Exit Sub End If Dim hRgn As Long ' Cut form hRgn = CreateRoundRectRgn(0, 0, frm.ScaleWidth + 1, frm.ScaleHeight + 1, 14, 14) SetWindowRgn frm.hWnd, hRgn, True DrawFormRect frm, 14 End Sub Public Sub ApplyWin11Effects(frm As Form) 'This only works on Windows 11 Build < 26200. 'For the other vesions, we use ApplyRoundedCorners() for rounded corners. If IsWindows11 = False Then Exit Sub If WinVerBuild >= 26200 Then Exit Sub On Error Resume Next Dim Pref As Long Dim rc As RECT Pref = DWMWCP_ROUND '-------------------------------------- ' Rounded corners Win11 '-------------------------------------- DwmSetWindowAttribute frm.hWnd, DWMWA_WINDOW_CORNER_PREFERENCE, Pref, 4 '-------------------------------------- ' DWM Shadow '-------------------------------------- rc.Left = 1 rc.Top = 1 rc.Right = 1 rc.Bottom = 1 DwmExtendFrameIntoClientArea frm.hWnd, rc End Sub




Reply With Quote