Userform resizing according to screen resolution

user_7923970 0
Viewed 16153

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.

Screen resolution

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?

userform zooming resize vba excel
3 Answers

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
user_59002300

Try this one:

  Private Sub UserForm_Initialize()
    With Application
    .WindowState = xlMaximized
    Zoom = Int(.Width / Me.Width * 100)
    Width = .Width
    Height = .Height
   End With
  End Sub
user_109688890 
Private Sub UserForm_Initialize()

    With Application

        Dim WD As Long
        Dim HD As Long
        Dim OrigW As Long
        Dim OrigH As Long

        Me.Width = 980.25 'Size the UserFrom was designed to
        Me.Height = 336.75 'Size the UserFrom was designed to
        WD = (Me.Width - Me.InsideWidth)
        HD = (Me.Height - Me.InsideHeight)
        OrigW = Me.Width
        OrigH = Me.Height

        Me.Width = (Application.Width / 1.481632653) 'The number you 
        'divide by should give you the original width of the UserForm 
        
        Me.Height = (((OrigH - HD) / (OrigW - WD)) * (Me.Width - WD))+HD

        Zoom = (((Me.Width) / OrigW) * 100)

        Me.Top = (Application.Height / 2) - (Me.Height / 2)
        Me.Left = (Application.Width / 2) - (Me.Width / 2)

    End With

End Sub
user_189649120
Related