Resizing a Userform

[Sharid]

I am using the follwing code (SEE BELOW AND ATTACHED USERFORM) to resize a userform and its objects, the code works fine on my desktop but NOT on my laptop. On my laptop the userform does NOT resize, it stays the same as it is in the design stage.

I am not sure if this is something to do with the two pc SPECs. The only thing I can see different is

Desktop = Windows 10 Enterprise
Laptop = Windows 10 Home
Buttons on UserForm = Missing controls when userform displays on the laptop
Code = Code on PC shows in RED for PtrSafe

could someone please advise

Item​	Desktop Spec​	Laptop Spec​
Spec​
Buttons on Userform​		missing buttons​
Windows Type​
How the code looks on the device​

THE CODE
1- API Code in a Standard Module:

       Option Explicit

#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "User32.dll" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private hwnd As LongPtr
Private lStyle As LongPtr
#Else
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private hwnd As Long
Private lStyle As Long
#End If

Private Const GWL_STYLE = -16
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MAXIMIZE = &HF030&

Private dInitWidth As Single
Private dInitHeight As Single
Private Ufrm As Object


Public Sub MakeFormResizeable(ByVal UF As Object)
Set Ufrm = UF
Call CreateMenu
Call StoreInitialControlMetrics

'OPTIONAL: maximize the form full-screen upon first showing.
'========
PostMessage hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, 0
End Sub


Public Sub AdjustSizeOfControls(Optional ByVal Dummey As Boolean)
Dim oCtrl As Control

For Each oCtrl In Ufrm.Controls
With oCtrl
If .Tag <> "" Then
.Width = Split(.Tag, "*")(0) * ((Ufrm.InsideWidth) / dInitWidth)
.Left = Split(.Tag, "*")(1) * (Ufrm.InsideWidth) / dInitWidth
.Height = Split(.Tag, "*")(2) * (Ufrm.InsideHeight) / dInitHeight
.Top = Split(.Tag, "*")(3) * (Ufrm.InsideHeight) / dInitHeight
If HasFont(oCtrl) Then
.Font.Size = Split(.Tag, "*")(4) * (Ufrm.InsideWidth) / dInitWidth
End If
End If
End With
Next
Ufrm.Repaint
End Sub

Private Sub StoreInitialControlMetrics()
Dim oCtrl As Control
Dim dFontSize As Currency

dInitWidth = Ufrm.InsideWidth
dInitHeight = Ufrm.InsideHeight
For Each oCtrl In Ufrm.Controls
With oCtrl
On Error Resume Next
dFontSize = IIf(HasFont(oCtrl), .Font.Size, 0)
On Error GoTo 0
.Tag = .Width & "*" & .Left & "*" & .Height & "*" & .Top & "*" & dFontSize
End With
Next
End Sub

Private Sub CreateMenu()
Call WindowFromAccessibleObject(Ufrm, hwnd)
lStyle = GetWindowLong(hwnd, GWL_STYLE)
lStyle = lStyle Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME
SetWindowLong hwnd, GWL_STYLE, lStyle
DrawMenuBar hwnd
End Sub

Private Function HasFont(ByVal oCtrl As Control) As Boolean
Dim oFont As Object

On Error Resume Next
Set oFont = CallByName(oCtrl, "Font", VbGet)
HasFont = Not oFont Is Nothing
End Function

2- Code Usage in the UserForm Module:

       Option Explicit

Private Sub UserForm_Initialize()
Call MakeFormResizeable(Me)
End Sub

Private Sub UserForm_Resize()
Call AdjustSizeOfControls
End Sub

You can download a DEMO Userform from here

 

[NdNoviceHlp]

I agree...
Module code....

Option Explicit
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Public X  As Long
Public Y  As Long
Public x_scale As Double
Public y_scale As Double
Public Type ControlPositionType
    Left As Single
    Top As Single
    Width As Single
    Height As Single
    FontSize As Single
End Type

Public m_ControlPositions() As ControlPositionType
Public m_FormWid As Double
Public m_FormHgt As Double

' Save the form's and controls' dimensions.
Public Sub SaveSizes(UF As Variant)
Dim i As Integer
Dim ctl As Control
    ' Save the controls' positions and sizes.
    ReDim m_ControlPositions(1 To UF.Controls.Count)
    i = 1
    On Error Resume Next
    For Each ctl In UF.Controls
        With m_ControlPositions(i)
                .Left = ctl.Left
                .Top = ctl.Top
                .Width = ctl.Width
                .Height = ctl.Height
                'no font for spinbtton ie. error
                If InStr(ctl.Name, "SpinButton") = False Then
                .FontSize = ctl.Font.Size
                End If
        End With
        i = i + 1
    Next ctl
If Err.Number <> 0 Then
On Error GoTo 0
End If
    ' Save the form's size.
    m_FormWid = UF.Width
    m_FormHgt = UF.Height
End Sub

Userform code...

Private Sub UserForm_Initialize()
Dim i As Integer, Wtemp As Double, HTemp As Double
Call SaveSizes(UserForm1)
X = GetSystemMetrics(SM_CXSCREEN)
Y = GetSystemMetrics(SM_CYSCREEN)
'original screen resolution 768 x 1024
Wtemp = (X - 1024) / 1024
Wtemp = 0.85 - Wtemp / 2 * 0.85 '(85% of screen)
HTemp = (Y - 768) / 768
HTemp = 0.9 - HTemp / 2 * 0.9 '(90% of screen)
Me.Width = Application.UsableWidth * Wtemp
Me.Height = Application.UsableHeight * HTemp
End Sub

Private Sub UserForm_Resize()
Call ResizeControls(UserForm1)
End Sub

' Arrange the controls for the new size.
Private Sub ResizeControls(UF As Variant)
Dim i As Integer, ctl As Control
    ' Get the form's current scale factors.
    x_scale = UF.Width / m_FormWid
    y_scale = UF.Height / m_FormHgt
    ' Position the controls.
    i = 1
    On Error Resume Next
    For Each ctl In Controls
        With m_ControlPositions(i)
                ctl.Left = x_scale * .Left
                ctl.Top = y_scale * .Top
                ctl.Width = x_scale * .Width
                ctl.Height = y_scale * .Height
                'no font for spinbtton ie. error
                If InStr(ctl.Name, "SpinButton") = False Then
                ctl.Font.Size = y_scale * .FontSize
                End If
        End With
        i = i + 1
    Next ctl
If Err.Number <> 0 Then
On Error GoTo 0
End If
End Sub

ps. Change "Userform1" to name of relevant userform
I sure hope I got this right now. Dave

 

[Sharid]

Thanks,

So far no errors are showing, I now need to get it to work on a 64bit system to see if it works. Currently the form only opens in design size and that the resize and minimise button missing.

 

[NdNoviceHlp]

I'm guessing U need to review the comments in this part of the code...

'original screen resolution 768 x 1024
Wtemp = (X - 1024) / 1024
Wtemp = 0.85 - Wtemp / 2 * 0.85 '(85% of screen)
HTemp = (Y - 768) / 768
HTemp = 0.9 - HTemp / 2 * 0.9 '(90% of screen)

The design screen resolution in this code was 768 x 1024. Adjust to suit your design resolution. U can mess with the .85 and .9 numbers to alter the size of the userform. HTH. Dave
ps Google 64 bit...

Private Declare PtrSafe Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long

 

[Jaafar Tribak]

It seems that the WindowFromAccessibleObject API returns a null hwnd when ran from your laptop.

Workbook Demo


Try this code instead :

Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
    #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
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "User32.dll" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib    "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

Private dInitWidth As Single, dInitHeight As Single, Ufrm As Object


Public Sub MakeFormResizeable(ByVal UF As Object)
    Set Ufrm = UF
    Call CreateMenu
    Call StoreInitialControlMetrics

    'OPTIONAL: maximize the form full-screen upon first showing.
    '========
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
   
    Const WM_SYSCOMMAND = &H112
    Const SC_MAXIMIZE = &HF030&

    Call IUnknown_GetWindow(UF, VarPtr(hwnd))
    Call PostMessage(hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, 0)
   
End Sub


Public Sub AdjustSizeOfControls(Optional ByVal Dummey As Boolean)

    Dim oCtrl As Control

    For Each oCtrl In Ufrm.Controls
        With oCtrl
            If .Tag <> "" Then
                .Width = Split(.Tag, "*")(0) * ((Ufrm.InsideWidth) / dInitWidth)
                .Left = Split(.Tag, "*")(1) * (Ufrm.InsideWidth) / dInitWidth
                .Height = Split(.Tag, "*")(2) * (Ufrm.InsideHeight) / dInitHeight
                .Top = Split(.Tag, "*")(3) * (Ufrm.InsideHeight) / dInitHeight
                If HasFont(oCtrl) Then
                    .Font.Size = Split(.Tag, "*")(4) * (Ufrm.InsideWidth) / dInitWidth
                End If
            End If
        End With
    Next
   
    Ufrm.Repaint
   
End Sub

Private Sub StoreInitialControlMetrics()

    Dim oCtrl As Control
    Dim dFontSize As Currency

    dInitWidth = Ufrm.InsideWidth
    dInitHeight = Ufrm.InsideHeight
   
    For Each oCtrl In Ufrm.Controls
        With oCtrl
            On Error Resume Next
                dFontSize = IIf(HasFont(oCtrl), .Font.Size, 0)
            On Error GoTo 0
            .Tag = .Width & "*" & .Left & "*" & .Height & "*" & .Top & "*" & dFontSize
        End With
    Next
   
End Sub

Private Sub CreateMenu()

    #If Win64 Then
        Dim hwnd As LongLong
        Dim lStyle As LongLong
    #Else
        Dim hwnd As Long
        Dim lStyle As Long
    #End If
   
    Const GWL_STYLE = -16
    Const WS_SYSMENU = &H80000
    Const WS_MINIMIZEBOX = &H20000
    Const WS_MAXIMIZEBOX = &H10000
    Const WS_THICKFRAME = &H40000
   
    Call IUnknown_GetWindow(Ufrm, VarPtr(hwnd))
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
   
    lStyle = lStyle Or WS_SYSMENU Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME
    Call SetWindowLong(hwnd, GWL_STYLE, lStyle)
    Call DrawMenuBar(hwnd)
   
End Sub

Private Function HasFont(ByVal oCtrl As Control) As Boolean

    Dim oFont As Object
   
    On Error Resume Next
    Set oFont = CallByName(oCtrl, "Font", VbGet)
    HasFont = Not oFont Is Nothing
   
End Function

 

[Sharid]

Jaafar

Your code has seemed to have done the trick, it is now working on my laptop, can I assume that this will also work for 32bit and 64bit systems, please advise?

Also a big thanks to Dave for taking the time out to help,

 

[NdNoviceHlp]

Sharid you are welcome and thanks for posting your outcome. Jaafar, as always, great code and the size of userforms and controls adjust to maintain design size with changes in screen resolution. However, it doesn't seem to keep the userform the same when scale and layout settings (formerly dpi settings) are adjusted. Maybe a bit more code adjustment is needed? Dave