Resizing a Userform

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
970
Office Version
  1. 2016
Platform
  1. Windows
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​
desktop spec.jpg
laptop spec.jpg
Buttons on Userform​
buttons.jpg
missing buttons.jpg
missing buttons​
Windows Type​
activation.jpg
activation.jpg
How the code looks on the device​
Desktop Code.jpg
code.jpg

THE CODE
1- API Code in a
Standard Module:
VBA Code:
       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:

VBA Code:
       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
 

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,667
The screen resolution and DPI (personal setttings) affect the userform's displayed size across pc's. Here's a link. HTH. Dave
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
970
Office Version
  1. 2016
Platform
  1. Windows
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
1605017215429.png


Desktop
1605017247649.png


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

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,667
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...
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...
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

Well-known Member
Joined
Apr 22, 2007
Messages
970
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Thanks for the update,

I keep getting this error message
1605021598953.png


If I disable this code then the form displays like this
1605021684715.png


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

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,667
Whoops! My bad I missed this part...
Userform code...
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,667

ADVERTISEMENT

If the pc is 64 bit U need to adjust this...
Code:
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

Well-known Member
Joined
Apr 22, 2007
Messages
970
Office Version
  1. 2016
Platform
  1. Windows
Cheers Dave,

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

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,667
I really messed this up...
module code..
Code:
Public x_scale As Double
Public y_scale As Double
My apologies. Dave
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
970
Office Version
  1. 2016
Platform
  1. Windows
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

1605024527789.png


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

Watch MrExcel Video

Forum statistics

Threads
1,118,599
Messages
5,573,136
Members
412,506
Latest member
StaffanExcel
Top