Userform size and position based on the screen used

I have a vba code that works perfectly and allows a userform to appear when the window opens :

Private Sub Worksheet_Activate()
    Static hasShown As Boolean
    If Not hasShown Then
        UserForm2.Show
        hasShown = True
    End If
End Sub

I also have a vba code that allows the userform to resize itself based on the screen it’s displays :

Private Sub AdjustControls(frm As UserForm)
    Dim ctrl As Control
    Dim scaleFactorWidth As Double
    Dim scaleFactorHeight As Double
    Dim initialFormWidth As Double
    Dim initialFormHeight As Double
    
    initialFormWidth = frm.InsideWidth
    initialFormHeight = frm.InsideHeight
    
    scaleFactorWidth = Application.Width / 1920
    scaleFactorHeight = Application.Height / 1080

    Dim initialTop As Double
    Dim initialLeft As Double
    
    For Each ctrl In frm.Controls
        If TypeName(ctrl) <> "Image" Then
            With ctrl
                .Width = .Width * scaleFactorWidth
                .Height = .Height * scaleFactorHeight
                .Top = .Top * scaleFactorHeight + (frm.InsideHeight - initialFormHeight * scaleFactorHeight) / 2
                .Left = .Left * scaleFactorWidth + (frm.InsideWidth - initialFormWidth * scaleFactorWidth) / 2
            End With
        End If
    Next ctrl
    
    Dim imgCtrl As Control
    For Each imgCtrl In frm.Controls
        If TypeName(imgCtrl) = "Image" Then
            initialTop = imgCtrl.Top
            initialLeft = imgCtrl.Left
            
            With imgCtrl
                .Top = initialTop * scaleFactorHeight
                .Left = initialLeft * scaleFactorWidth
                ' Optionnel : ajuster la taille des images si nécessaire
                '.Width = .Width * scaleFactorWidth
                '.Height = .Height * scaleFactorHeight
            End With
        End If
    Next imgCtrl
End Sub

Finally, I have a vba code that defines the starting position :

Private Sub UserForm_Initialize()
    Me.StartUpPosition = 0 'Manual
    Me.Top = Application.ActiveWindow.Top + (Application.ActiveWindow.Height / 2) - (Me.Height / 2)
    Me.Left = Application.ActiveWindow.Left + (Application.ActiveWindow.Width / 2) - (Me.Width / 2)
    AdjustControls Me
End Sub

My problem is that the second code doesn’t really work, as I have two images field on that userform, the first takes all the space and the second one is a “continue” button that is also an image, but in the right corner. The code move the continue button at the center of the screen.

My goal is really to be able to adjust the userform so it keeps the same proportions and positions whatever the screen used.

There will be a second button “submit” on the second userform.

Well there is still work to be done but I think this will go a long way towards getting it right.

I replaced Application.Width and Application.Width with GetScreenHeight and GetScreenWidth because the Application dimension will vary if the Application is no maximized.

I create a class (ResizeHandler) to help resize and position the controls.

Common aspect ratios include 4:3 for legacy monitors, 16:9 for modern widescreens, 5:4 for some older monitors, 16:10 for certain laptops, and 21:9 for ultrawide displays. You may want to consider a different approach to your calculations. I would use the screen height to get a percentage to make the adjustment. Adjusting the userform zoom is another option.

I think that the different aspect ratios will be problematic to the current approach. The aspect ratios will likely cause the form to images to get skewed. It may be better to just adjust the form height.

Public Module Code

Option Explicit

#If Mac Then
    Rem: Function to get screen height on Mac using AppleScript
    Function GetScreenHeight() As Double
        Dim Script As String
        Dim Height As Double
        Script = "tell application ""Finder"" " & vbCrLf & _
                 "set screenHeight to screen resolution's height" & vbCrLf & _
                 "end tell" & vbCrLf & _
                 "return screenHeight"
        Rem: Run the AppleScript to get the screen height
        Height = MacScript(Script)
        GetScreenHeight = Height
    End Function
    
    Rem: Function to get screen width on Mac using AppleScript
    Function GetScreenWidth() As Double
        Dim Script As String
        Dim Width As Double
        Script = "tell application ""Finder"" " & vbCrLf & _
                 "set screenWidth to screen resolution's width" & vbCrLf & _
                 "end tell" & vbCrLf & _
                 "return screenWidth"
        Rem: Run the AppleScript to get the screen width
        Width = MacScript(Script)
        GetScreenWidth = Width
    End Function
#Else
    Rem: Declare the Windows API to get screen height and width, supporting 32/64-bit
    #If VBA7 Then
        Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    #Else
        Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    #End If
    
    Rem: Function to get screen height on Windows
    Function GetScreenHeight() As Double
        GetScreenHeight = GetSystemMetrics(1) ' SM_CYSCREEN = 1 for screen height
    End Function
    
    Rem: Function to get screen width on Windows
    Function GetScreenWidth() As Double
        GetScreenWidth = GetSystemMetrics(0) ' SM_CXSCREEN = 0 for screen width
    End Function
#End If

Function PercentageTop(Parent As Object, Child As Object) As Double
    ' Calculate the percentage of the Child's Top position relative to the Parent
    PercentageTop = (Child.Top - Parent.Top) / Parent.Height * 100
End Function

Function PercentageLeft(Parent As Object, Child As Object) As Double
    ' Calculate the percentage of the Child's Left position relative to the Parent
    PercentageLeft = (Child.Left - Parent.Left) / Parent.Width * 100
End Function

Class: ResizeHandler Code
Rem Class: ResizeHandler
Option Explicit

Private pControl As MSForms.Control
Private pParentForm As Object
Private pInitialLeftPercent As Double
Private pInitialTopPercent As Double

Rem Initialize the class with the control and its parent form
Public Sub Initialize(ParentForm As Object, Control As MSForms.Control)
    Set pControl = Control
    Set pParentForm = ParentForm
    
    Rem Store the initial percentage positions relative to the original UserForm size
    pInitialLeftPercent = pControl.Left / pParentForm.Width * 100
    pInitialTopPercent = pControl.Top / pParentForm.Height * 100
End Sub

Rem Method to resize the control based on the parent form's new dimensions
Public Sub ResizeControl()
    Rem Resize and reposition the control
    With pControl
        .Height = .Height * GetScreenHeight() / 1080
        .Width = .Width * GetScreenWidth() / 1920
        .Left = pParentForm.Width * (pInitialLeftPercent / 100)
        .Top = pParentForm.Height * (pInitialTopPercent / 100)
        .PictureSizeMode = fmPictureSizeModeZoom
    End With
End Sub

Userform Code

Private Sub UserForm_Initialize()
    ' Declare two instances of ResizeHandler class for ContinueButton and BackgroundImage
    Dim ContinueButtonResizer As ResizeHandler
    Dim BackgroundImageResizer As ResizeHandler

    ' Initialize both resizers
    Set ContinueButtonResizer = New ResizeHandler
    ContinueButtonResizer.Initialize Me, ContinueButton
    
    Set BackgroundImageResizer = New ResizeHandler
    BackgroundImageResizer.Initialize Me, BackgroundImage

    ' Resize the UserForm first
    With Me
        .BackColor = RGB(179, 0, 242)
        .PictureSizeMode = fmPictureSizeModeZoom
        .StartUpPosition = 0
        ' Set the form to the center of the screen based on new size
        .Height = .Height * GetScreenHeight() / 1080
        .Width = .Width * GetScreenWidth() / 1920
        .Top = (GetScreenHeight / 2) - (.Height / 2)
        .Left = (GetScreenWidth / 2) - (.Width / 2)
    End With

    ' Resize and reposition the ContinueButton and BackgroundImage using the class
    ContinueButtonResizer.ResizeControl
    BackgroundImageResizer.ResizeControl
End Sub

Filed under: Kiến thức lập trình - @ 17:49

Thẻ: excelvbauserform

Thiết kế website giá rẻ

Danh mục

Userform size and position based on the screen used