Auto adjust Excel UserForm according to the screen resolution

Question

I have a User Form on Excel with several controls and nested controls that I need to adjust depending on the resolution of the screen.

However after trying several codes to readjust the .Top .Left .Height .Width properties and even the .Font.Size so that the texts in the different controls would keep the same aspect ratio, I was unsuccessful.

After researching this and looking for answers and codes from several different sources I finally was able to write the necessary code to readjust the ratios.

I'm sorry but I'm really unable to cite the different sources because I also got them through a prolonged period of time and on different occasions.

Answer 1

The following code should be on a module of it's own.

Option Explicit

' This module includes Private declarations for certain Windows API functions
' plus code for Public Function Screen, which returns metrics for the screen displaying ActiveWindow
' This module requires VBA7 (Office 2010 or later)
' DEVELOPER: J. Woolley (for wellsr.com)
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function MonitorFromWindow Lib "user32" _
    (ByVal hWnd As LongPtr, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" _
    (ByVal hMonitor As LongPtr, ByRef lpMI As MONITORINFOEX) As Boolean
Private Declare PtrSafe Function CreateDC Lib "gdi32" Alias "CreateDCA" _
    (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Const SM_CMONITORS              As Long = 80    ' number of display monitors
Private Const MONITOR_CCHDEVICENAME     As Long = 32    ' device name fixed length
Private Const MONITOR_PRIMARY           As Long = 1
Private Const MONITOR_DEFAULTTONULL     As Long = 0
Private Const MONITOR_DEFAULTTOPRIMARY  As Long = 1
Private Const MONITOR_DEFAULTTONEAREST  As Long = 2
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type MONITORINFOEX
   cbSize As Long
   rcMonitor As RECT
   rcWork As RECT
   dwFlags As Long
   szDevice As String * MONITOR_CCHDEVICENAME
End Type
Private Enum DevCap     ' GetDeviceCaps nIndex (video displays)
    HORZSIZE = 4        ' width in millimeters
    VERTSIZE = 6        ' height in millimeters
    HORZRES = 8         ' width in pixels
    VERTRES = 10        ' height in pixels
    BITSPIXEL = 12      ' color bits per pixel
    LOGPIXELSX = 88     ' horizontal DPI (assumed by Windows)
    LOGPIXELSY = 90     ' vertical DPI (assumed by Windows)
    COLORRES = 108      ' actual color resolution (bits per pixel)
    VREFRESH = 116      ' vertical refresh rate (Hz)
End Enum

'Addition made to this module for UserForm resize through windows API

Private Const GWL_STYLE = -16
Private Const WS_CAPTION = &HC00000
Private Const WS_THICKFRAME = &H40000

#If VBA7 Then
    Private Declare PtrSafe Function GetWindowLong _
        Lib "user32" Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong _
        Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar _
        Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare PtrSafe Function FindWindowA _
        Lib "user32" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#Else
    Private Declare PtrSafe Function GetWindowLong _
        Lib "user32" Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong _
        Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar _
        Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare PtrSafe Function FindWindowA _
        Lib "user32" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If

Public Function Screen(Item As String) As Variant
' Return display screen Item for monitor displaying ActiveWindow
' Patterned after Excel's built-in information functions CELL and INFO
' Supported Item values (each must be a string, but alphabetic case is ignored):
' HorizontalResolution or pixelsX
' VerticalResolution or pixelsY
' WidthInches or inchesX
' HeightInches or inchesY
' DiagonalInches or inchesDiag
' PixelsPerInchX or ppiX
' PixelsPerInchY or ppiY
' PixelsPerInch or ppiDiag
' WinDotsPerInchX or dpiX
' WinDotsPerInchY or dpiY
' WinDotsPerInch or dpiWin ' DPI assumed by Windows
' AdjustmentFactor or zoomFac ' adjustment to match actual size (ppiDiag/dpiWin)
' IsPrimary ' True if primary display
' DisplayName ' name recognized by CreateDC
' Update ' update cells referencing this UDF and return date/time
' Help ' display all recognized Item string values
' EXAMPLE: =Screen("pixelsX")
' Function Returns #VALUE! for invalid Item
    Dim xHSizeSq As Double, xVSizeSq As Double, xPix As Double, xDot As Double
    Dim hWnd As LongPtr, hDC As LongPtr, hMonitor As LongPtr
    Dim tMonitorInfo As MONITORINFOEX
    Dim nMonitors As Integer
    Dim vResult As Variant
    Dim sItem As String
    Application.Volatile
    nMonitors = GetSystemMetrics(SM_CMONITORS)
    If nMonitors < 2 Then
        nMonitors = 1                                       ' in case GetSystemMetrics failed
        hWnd = 0
    Else
        hWnd = GetActiveWindow()
        hMonitor = MonitorFromWindow(hWnd, MONITOR_DEFAULTTONULL)
        If hMonitor = 0 Then
            Debug.Print "ActiveWindow does not intersect a monitor"
            hWnd = 0
        Else
            tMonitorInfo.cbSize = Len(tMonitorInfo)
            If GetMonitorInfo(hMonitor, tMonitorInfo) = False Then
                Debug.Print "GetMonitorInfo failed"
                hWnd = 0
            Else
                hDC = CreateDC(tMonitorInfo.szDevice, 0, 0, 0)
                If hDC = 0 Then
                    Debug.Print "CreateDC failed"
                    hWnd = 0
                End If
            End If
        End If
    End If
    If hWnd = 0 Then
        hDC = GetDC(hWnd)
        tMonitorInfo.dwFlags = MONITOR_PRIMARY
        tMonitorInfo.szDevice = "PRIMARY" & vbNullChar
    End If
    sItem = Trim(LCase(Item))
    Select Case sItem
    Case "horizontalresolution", "pixelsx"                  ' HorizontalResolution (pixelsX)
        vResult = GetDeviceCaps(hDC, DevCap.HORZRES)
    Case "verticalresolution", "pixelsy"                    ' VerticalResolution (pixelsY)
        vResult = GetDeviceCaps(hDC, DevCap.VERTRES)
    Case "widthinches", "inchesx"                           ' WidthInches (inchesX)
        vResult = GetDeviceCaps(hDC, DevCap.HORZSIZE) / 25.4
    Case "heightinches", "inchesy"                          ' HeightInches (inchesY)
        vResult = GetDeviceCaps(hDC, DevCap.VERTSIZE) / 25.4
    Case "diagonalinches", "inchesdiag"                     ' DiagonalInches (inchesDiag)
        vResult = Sqr(GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2) / 25.4
    Case "pixelsperinchx", "ppix"                           ' PixelsPerInchX (ppiX)
        vResult = 25.4 * GetDeviceCaps(hDC, DevCap.HORZRES) / GetDeviceCaps(hDC, DevCap.HORZSIZE)
    Case "pixelsperinchy", "ppiy"                           ' PixelsPerInchY (ppiY)
        vResult = 25.4 * GetDeviceCaps(hDC, DevCap.VERTRES) / GetDeviceCaps(hDC, DevCap.VERTSIZE)
    Case "pixelsperinch", "ppidiag"                         ' PixelsPerInch (ppiDiag)
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xPix = GetDeviceCaps(hDC, DevCap.HORZRES) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTRES) ^ 2
        vResult = 25.4 * Sqr(xPix / (xHSizeSq + xVSizeSq))
    Case "windotsperinchx", "dpix"                          ' WinDotsPerInchX (dpiX)
        vResult = GetDeviceCaps(hDC, DevCap.LOGPIXELSX)
    Case "windotsperinchy", "dpiy"                          ' WinDotsPerInchY (dpiY)
        vResult = GetDeviceCaps(hDC, DevCap.LOGPIXELSY)
    Case "windotsperinch", "dpiwin"                         ' WinDotsPerInch (dpiWin)
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xDot = GetDeviceCaps(hDC, DevCap.LOGPIXELSX) ^ 2 * xHSizeSq + GetDeviceCaps(hDC, DevCap.LOGPIXELSY) ^ 2 * xVSizeSq
        vResult = Sqr(xDot / (xHSizeSq + xVSizeSq))
    Case "adjustmentfactor", "zoomfac"                      ' AdjustmentFactor (zoomFac)
        xHSizeSq = GetDeviceCaps(hDC, DevCap.HORZSIZE) ^ 2
        xVSizeSq = GetDeviceCaps(hDC, DevCap.VERTSIZE) ^ 2
        xPix = GetDeviceCaps(hDC, DevCap.HORZRES) ^ 2 + GetDeviceCaps(hDC, DevCap.VERTRES) ^ 2
        xDot = GetDeviceCaps(hDC, DevCap.LOGPIXELSX) ^ 2 * xHSizeSq + GetDeviceCaps(hDC, DevCap.LOGPIXELSY) ^ 2 * xVSizeSq
        vResult = 25.4 * Sqr(xPix / xDot)
    Case "isprimary"                                        ' IsPrimary
        vResult = CBool(tMonitorInfo.dwFlags And MONITOR_PRIMARY)
    Case "displayname"                                      ' DisplayName
        vResult = tMonitorInfo.szDevice & vbNullChar
        vResult = Left(vResult, (InStr(1, vResult, vbNullChar) - 1))
    Case "update"                                           ' Update
        vResult = Now
    Case "help"                                             ' Help
        vResult = "HorizontalResolution (pixelsX), VerticalResolution (pixelsY), " _
            & "WidthInches (inchesX), HeightInches (inchesY), DiagonalInches (inchesDiag), " _
            & "PixelsPerInchX (ppiX), PixelsPerInchY (ppiY), PixelsPerInch (ppiDiag), " _
            & "WinDotsPerInchX (dpiX), WinDotsPerInchY (dpiY), WinDotsPerInch (dpiWin), " _
            & "AdjustmentFactor (zoomFac), IsPrimary, DisplayName, Update, Help"
    Case Else                                               ' Else
        vResult = CVErr(xlErrValue)                         ' return #VALUE! error (2015)
    End Select
    If hWnd = 0 Then
        ReleaseDC hWnd, hDC
    Else
        DeleteDC hDC
    End If
    Screen = vResult
End Function

Public Function adjustToRes(UserForm As Object, designScreenWidthPixels As Single, designScreenHeightPixels As Single, _
                        Optional lowerLimitHeight As Single = 768, Optional lowerLimitWidth As Single = 1024) As Boolean

Dim rateWidth As Double, rateHeight As Double
Dim currentScreenWidth As Single, currentScreenHeight As Single

currentScreenWidth = Screen("pixelsX")
currentScreenHeight = Screen("pixelsY")

If currentScreenHeight < lowerLimitHeight Or currentScreenWidth < lowerLimitWidth Then
    adjustToRes = False
    Exit Function
End If

rateWidth = currentScreenWidth / designScreenWidthPixels
rateHeight = currentScreenHeight / designScreenHeightPixels

If rateWidth = 1 And rateHeight = 1 Then
    adjustToRes = True
    Exit Function
End If

With UserForm
    
    If rateHeight > rateWidth Then
        .Zoom = .Zoom * rateHeight
    Else
        .Zoom = .Zoom * rateWidth
    End If
    .Height = .Height * rateHeight
    .Width = .Width * rateWidth
'    .ScrollHeight = .ScrollHeight * rateHeight
'    .ScrollWidth = .ScrollWidth * rateWidth
    
End With

adjustToRes = True

End Function

Afterwards you need to use the adjustToRes function on the initialize event of the UserForm.

Private Sub UserForm_Initialize()

Dim adjusted As Boolean

adjusted = adjustToRes(Me, 1920, 1080)

End Sub

The adjustToRes function needs 3 required arguments and has 2 optional ones.

Public Function adjustToRes(UserForm As Object, designScreenWidthPixels As Single, designScreenHeightPixels As Single, _
                        Optional lowerLimitHeight As Single = 768, Optional lowerLimitWidth As Single = 1024) As Boolean

UserForm is obviously the UserForm object that needs resizing.

designScreenWidthPixels has to be the number of horizontal pixels of the screen for which the UserForm was designed.

For example if the UserForm was created using a screen with resolution of 1920*1080 then

designScreenWidthPixels = 1920

designScreenHeightPixels would then be the number of vertical pixels of the screen for which the UserForm was designed.

In the case of this example that would be 1080.

The optional argument lowerLimitHeight is used to exit the function without any resizing if the vertical resolution of the current screen is less than lowerLimitHeight. If no argument is provided then by default lowerLimitHeight = 768.

The optional argument lowerLimitWidth does the same thing as lowerLimitHeight but concerning the horizontal resolution of the screen. If no argument is provided then by default lowerLimitHeight = 1024.

You can of course change this default values if it doesn't suit you.

The function adjustToRes returns False if no resizing was done, otherwise if no resizing was needed or the resizing was successfull then it returns True.