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]

The screen resolution and DPI (personal setttings) affect the userform's displayed size across pc's. Here's a link. HTH. Dave

Userform size displays incorrectly

Hi, I have created a tool for many users in my company. The interface is built around a main userform. I am having an issue with only one user where the userform seems to be so zoomed in on her screen that she is not able to access all of the content. I check her resolution and it is the same...

www.mrexcel.com

 

[Sharid]

Thanks for your input, I have done as you advised. The DPI change has made the form display larger, however it has not got rid of the problem.

I think that my issues is that the code for resizing the form is NOT firing up on my laptop as there are several buttons missing on the top right hand corner of the userform,

Laptop

Desktop

If I change the DPI the form displays larger and goes off screen.

 

[NdNoviceHlp]

I'm guessing it's the screen resolution that's different. I see that I've updated the code at the link, so I'll post it.
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 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

ps. Change "Userform1" to name of relevant userform
HTH. Dave
pps. For 32 bit instal only

 

[Sharid]

Thanks for the update,

I keep getting this error message

If I disable this code then the form displays like this

I am assuming you code replaces mine?
Also what happens if the PC is 64bit?

 

[NdNoviceHlp]

Whoops! My bad I missed this part...
Userform code...

' 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

Dave

 

[NdNoviceHlp]

If the pc is 64 bit U need to adjust this...

Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Which unfortunately I'm not that sure how to do. Maybe just change the Long to LongPtr?
Dave

 

[Sharid]

Cheers Dave,

I placed the code in the userform and I am getting this error message

 

[NdNoviceHlp]

I really messed this up...
module code..

Public x_scale As Double
Public y_scale As Double

My apologies. Dave

 

[Sharid]

Sorry Dave, but I am totally confused now. I have now placed the new code in a module and taken it out of the userform and I keep getting the first error message

Could you please the whole code as it should be and where it should go.