I have an Excel userform I want to resize on opening to fit the screen resolution.
I get the height and the width through Application.Height
and Application.Width
, and normally with these two parameters and the following code, one should do the trick:
Me.Top = Application.Top
Me.Left = Application.Left
Me.Height = Application.Height
Me.Width = Application.Width
Here is the problem: Windows (at least since 7) has a parameter to set the zoom on the desktop, and this seems to compromise the code.
When changing from 100% to 150% for example, the form's width and height are set correctly but the zoom isn't. I'd like to change it according to Windows desktop zoom.
How can I retrieve the Desktop zoom parameter?
Try this:
Option Explicit
'Function to get screen resolution
#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As LongPtr) As Long
'Functions to get DPI
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
#Else
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
'Functions to get DPI
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
#End If
Private Const LOGPIXELSX = 88 'Pixels/inch in X
Private Const POINTS_PER_INCH As Long = 72 'A point is defined as 1/72 inches
'Return DPI
Public Function PointsPerPixel() As Double
'hDC LongPtr if VBA7
Dim hDC As Long
Dim lDotsPerInch As Long
hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
ReleaseDC 0, hDC
End Function
Private Sub UserForm_Initialize()
Dim w As Long, h As Long
w = GetSystemMetrics32(0) ' Screen Resolution width in points
h = GetSystemMetrics32(1) ' Screen Resolution height in points
With Me
.StartUpPosition = 2
.Width = w * PointsPerPixel * 0.5 'Userform width= Width in Resolution * DPI * 50%
.Height = h * PointsPerPixel * 0.5 'Userform height= Height in Resolution * DPI * 50%
End With
End Sub
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With