Resize userform using API - maintain proportion

Formula11

Active Member
Joined
Mar 1, 2005
Messages
496
Office Version
  1. 365
Platform
  1. Windows
I've attempted to modify API code found on another web page to resize userform in proportion or aspect ratio (Width/Height = constant).

Did a fair amount of testing, it's a bit tricky to figure out sequence of code ... suggest that UserForm_Resize is called up before UserForm_Initialize ... and each may be called up twice???

So far it works when I change form size (in proportion) using the Hor. and 45deg grips, but not the Ver. grip.

Is it possible for one of the following:
- Change form size in proportion using all three grips (Hor., Ver, 45deg).
- Remove the options for the Hor. and Ver. grips entirely, so only change using the 45deg grip.

1740982199631.png



MODULE CODE
VBA Code:
Option Explicit

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

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

Sub ResizeWindowSettings(frm As Object, show As Boolean)
'Debug.Print "api_mod"
    Dim windowStyle As Long
    Dim windowHandle As Long
    
    windowHandle = FindWindowA(vbNullString, frm.Caption)
    windowStyle = GetWindowLong(windowHandle, GWL_STYLE)
    
    If show = False Then
        windowStyle = windowStyle And (Not WS_THICKFRAME)
    Else
        windowStyle = windowStyle + (WS_THICKFRAME)
    End If

    SetWindowLong windowHandle, GWL_STYLE, windowStyle
    DrawMenuBar windowHandle
End Sub

Sub Open_Form_API_mod()
    myUserForm_API.show vbModeless
End Sub

FORM CODE
VBA Code:
Option Explicit

'form proportion
Dim form_proportion As Double

'to maintain proportions
Dim cnt As Long 'counter
Dim arrW() As Variant, arrH() As Variant 'W=Width and H=Height
Dim init_width, init_height As Double
Dim W1 As Double, W2 As Double, H1 As Double, H2 As Double '1=Previous and 2=New

Private Sub UserForm_Initialize()
    Dim width_at_Initialize
    'proportions ...
    form_proportion = 1.41
    'size
    width_at_Initialize = 120
    Me.Width = width_at_Initialize + 1 * (Me.Width - Me.InsideWidth)
    Me.Height = form_proportion * width_at_Initialize + 1 * (Me.Height - Me.InsideHeight)
    init_width = Me.Width
    init_height = Me.Height
    'Call the Window API to enable resizing
    Call ResizeWindowSettings(Me, True)
    'arrays
    ReDim arrW(0)
    ReDim arrH(0)
End Sub

'this is called up multiple (???) times initialy, and twice (???) when resizing form
'-----------------------------------------------------------------------------------
Private Sub UserForm_Resize()
    On Error Resume Next
    'arrays
    ReDim Preserve arrW(cnt)
    ReDim Preserve arrH(cnt)
    arrW(cnt) = Me.Width
    arrH(cnt) = Me.Height

    If cnt = 0 Then
        'nothing ... init not called up yet
    End If
    
    If cnt = 1 Then
        'nothing ... init not called up yet
    End If

    If cnt = 2 Then 'effectively the process of getting the form up one screen, seems to be 3 iterations
        W2 = arrW(cnt): W1 = init_width
        H2 = arrH(cnt): H1 = init_height
Debug.Print "(" & cnt & ")" & "W2 =" & arrW(cnt) & ", W1 = " & init_width & " ... " & "H2 =" & arrH(cnt) & ", H1 = " & init_height
    End If

    If cnt > 2 Then
        W2 = arrW(cnt): W1 = arrW(cnt - 1)
        H2 = arrH(cnt): H1 = arrH(cnt - 1)
Debug.Print "(" & cnt & ")" & "W2 =" & arrW(cnt) & ", W1 = " & arrW(cnt - 1) & " ... " & "H2 =" & arrH(cnt) & ", H1 = " & arrH(cnt - 1)
    End If
    'resize in proportion
    '--------------------
    If cnt >= 2 Then
        'important to round Double
        If Round(W2, 1) = Round(W1, 1) Then
            Me.Height = H2
            Me.Width = (1 / form_proportion) * H2
        End If
        If Round(H2, 1) = Round(H1, 1) Then
            Me.Width = W2
            Me.Height = form_proportion * W2
        End If
        If (Round(W2, 1) <> Round(W1, 1)) And (Round(H2, 1) <> Round(H1, 1)) Then
            Me.Width = W2
            Me.Height = form_proportion * W2
        End If
    End If
    'counter
    cnt = cnt + 1
    On Error GoTo 0
End Sub
 
I don't think this is going to be easy without subclassing the userform and intercepting the resizing messages.
I have posted code in this forum before for subclassing userforms but although the code is stable, it is very involved, so I wouldn't suggest it for what you want to achieve here.

- Remove the options for the Hor. and Ver. grips entirely, so only change using the 45deg grip.
Yes. Leaving only the diagonal (corner) grips cursors would probably work without needing to subclass the userform ... Let me see if I can post some working code.
 
Upvote 0
See if this workaround works for you:
The options for the Hor. and Ver. grips are entirely disbaled ... Only the corner grips are functional for resizing the userform, hence, preserving the form aspect ratio. (no subclassing)

Workbook Example
FormAspectRatio.xlsm





Code in the UserForm Module:
VBA Code:
Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare Function ReleaseCapture Lib "user32" () As Long
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type CURSORINFO
    cbSize As Long
    flags As Long
    hCursor As LongPtr
    ptScreenPos As POINTAPI
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
End Type


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

Private Sub UserForm_Resize()
    If GetIconXHotSpot <> 8& Then
        Call ReleaseCapture
    End If
End Sub

Private Sub MakeFormResizeable(ByVal Form As UserForm)

  Const GWL_STYLE As Long = -16&, WS_THICKFRAME = &H40000, WS_MAXIMIZEBOX = &H10000, WS_MINIMIZEBOX = &H20000
  Dim hwnd As LongPtr

   Call IUnknown_GetWindow(Me, hwnd)
    ' Remove (WS_MAXIMIZEBOX + WS_MINIMIZEBOX) if you don't want to have the Max\Min size boxes.
   Call SetWindowLong(hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) + WS_THICKFRAME + (WS_MAXIMIZEBOX + WS_MINIMIZEBOX))

End Sub

Private Function GetIconXHotSpot() As Long

    Dim uCurInfo As CURSORINFO, uIconInfo As ICONINFO
 
    uCurInfo.cbSize = LenB(uCurInfo)
    If GetCursorInfo(uCurInfo) Then
        If GetIconInfo(uCurInfo.hCursor, uIconInfo) Then
            GetIconXHotSpot = uIconInfo.xHotspot
        End If
    End If

End Function
 
Last edited:
Upvote 0
In an effort to reduce the code size, I neglected to delete the bitmap and mask objects causing a memory leak.

Please, ignore the previous code and use the following one: (The linked workbook example has also been updated)

In the UerForm Module:
VBA Code:
Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function ReleaseCapture Lib "user32" () As Long
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type CURSORINFO
    cbSize As Long
    flags As Long
    hCursor As LongPtr
    ptScreenPos As POINTAPI
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As LongPtr
    hbmColor As LongPtr
End Type


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

Private Sub UserForm_Resize()
    If GetIconXHotSpot <> 8& Then
        Call ReleaseCapture
    End If
End Sub

Private Sub MakeFormResizeable(ByVal Form As UserForm)

    Const GWL_STYLE As Long = -16&, WS_THICKFRAME = &H40000, WS_MAXIMIZEBOX = &H10000, WS_MINIMIZEBOX = &H20000
    Dim hwnd As LongPtr

    Call IUnknown_GetWindow(Me, hwnd)
     ' Remove (WS_MAXIMIZEBOX + WS_MINIMIZEBOX) if you don't want to have the Max\Min size boxes.
    Call SetWindowLong(hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) + WS_THICKFRAME + (WS_MAXIMIZEBOX + WS_MINIMIZEBOX))

End Sub

Private Function GetIconXHotSpot() As Long

    Dim uCurInfo As CURSORINFO, uIconInfo As ICONINFO
    
    uCurInfo.cbSize = LenB(uCurInfo)
    If GetCursorInfo(uCurInfo) Then
        If GetIconInfo(uCurInfo.hCursor, uIconInfo) Then
            Call DeleteObject(uIconInfo.hbmColor)
            Call DeleteObject(uIconInfo.hbmMask)
            GetIconXHotSpot = uIconInfo.xHotspot
        End If
    End If

End Function
 
Upvote 0
Thanks Jaafar, unfortunately it doesn't work on my system as per video, tried both on workbook demo and separate workbook.
If the code from previous working is involved/unstable, I can accept that and move on.
Cheers.
 
Upvote 0
Thanks Jaafar, unfortunately it doesn't work on my system as per video, tried both on workbook demo and separate workbook.
If the code from previous working is involved/unstable, I can accept that and move on.
Cheers.
No Problem.

Do you mind changing the code in the UserForm_Resize event as follows :
VBA Code:
Private Sub UserForm_Resize()
    Dim lRet As Long
    lRet = GetIconXHotSpot
    Debug.Print lRet
End Sub

Now, can you please try again resizing the form (Horz, Vert and Diagonally ) and let me know what values you see in the immediate window ?

I need to know those values in order to confirm if cursor icon hotspots are identical accross systems/screen settings.

Thanks.
 
Last edited:
Upvote 0
Ok, that's good. Those are the same values I too get so, they seem to be the same accross diff systems as I had wished.

I believe I have identified the issue with the code I’ve shared thus far. Specifically, the diagonal resize grips are still enabling the form to be resized on only one side.

Here is an alternative code that ensures the userform's aspect ratio remains intact, regardless of which side is being resized.

The code avoids relying on the UserForm_Resize event, as it results in an undesirable flicker of the userform. Instead, it monitors resizing through a background loop.

To use it, simply toggle the following custom property:
LockFormAspectRatio(Me) = True\False

Workbook Example:
FormAspectRatio_V.2.xlsm







1- In a Standard Module:
VBA Code:
Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare PtrSafe Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    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 GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetCursorInfo Lib "user32" (lpCursorInfo As CURSORINFO) As Long
    Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As LongPtr, lpIconInfo As ICONINFO) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
#End If

Private Enum RESIZE_FLAGS
    WS_THICKFRAME = &H40000
    WS_MAXIMIZEBOX = &H10000
    WS_MINIMIZEBOX = &H20000
End Enum

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type CURSORINFO
    cbSize As Long
    flags As Long
    hCursor As LongPtr
    ptScreenPos As POINTAPI
End Type

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As LongPtr
    hbmColor As LongPtr
End Type

Private bLockAspectRatio As Boolean, bExitLoop As Boolean
Private objForm As Object


Public Property Let LockFormAspectRatio(Form As Object, bLock As Boolean)
    bExitLoop = True
    Set objForm = Form
    Application.OnTime Now, "MakeFormResizeable"
    If bLock Then
        bLockAspectRatio = True
    Else
        bLockAspectRatio = False
    End If
    On Error Resume Next
        Call CallByName(Form, "AspectRatio", VbLet, Format(Form.Width / Form.Height, "0.00"))
    On Error GoTo 0
End Property

Public Property Get LockFormAspectRatio(Form As Object) As Boolean
    LockFormAspectRatio = bLockAspectRatio
End Property

' ____________________________________ PRIVATE ROUTINES ____________________________________

Private Sub MakeFormResizeable()

    Const GWL_STYLE As Long = -16&
    Dim eRESIZE_FLAGS As RESIZE_FLAGS
    Dim hwnd As LongPtr
    Dim lStyle As Long
  
    ' Remove (WS_MAXIMIZEBOX + WS_MINIMIZEBOX) if you don't want to have the Max\Min size boxes.
    eRESIZE_FLAGS = WS_THICKFRAME + WS_MINIMIZEBOX + WS_MAXIMIZEBOX
  
    Call IUnknown_GetWindow(objForm, hwnd)
  
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    If Not CBool(lStyle And eRESIZE_FLAGS) Then
        lStyle = lStyle Or eRESIZE_FLAGS
        Call SetWindowLong(hwnd, GWL_STYLE, lStyle)
        Call DrawMenuBar(hwnd)
    End If
  
    If bLockAspectRatio Then
        Call AdjustRatio(objForm, hwnd)
    End If

End Sub

Private Sub AdjustRatio(ByVal Form As Object, ByVal hwnd As LongPtr)

    Dim lRet As Long, sngAspectRatio As Single
  
    On Error GoTo errHandler
  
    With Form
        sngAspectRatio = .Width / .Height
        bExitLoop = False
        Do
            lRet = GetIconXHotSpot
            ' Horz + Diagonal resizing
            If lRet = 11& Or lRet = 8& Then
                .Height = .Width / sngAspectRatio
            End If
            ' Vert + Diagonal resizing
            If lRet = 4& Or lRet = 8& Then
                .Width = .Height * sngAspectRatio
            End If
            DoEvents
        Loop Until bExitLoop Or IsWindow(hwnd) = 0&
    End With
  
errHandler:
    Set objForm = Nothing

End Sub

Private Function GetIconXHotSpot() As Long

    Dim uCurInfo As CURSORINFO, uIconInfo As ICONINFO

    uCurInfo.cbSize = LenB(uCurInfo)
    If GetCursorInfo(uCurInfo) Then
        If GetIconInfo(uCurInfo.hCursor, uIconInfo) Then
            Call DeleteObject(uIconInfo.hbmColor)
            Call DeleteObject(uIconInfo.hbmMask)
            GetIconXHotSpot = uIconInfo.xHotspot
        End If
    End If

End Function


2- Code Usage Example ( In the UserForm Module)
VBA Code:
Option Explicit

Public AspectRatio As Single

Private Sub UserForm_Initialize()
    CheckBox1 = True
End Sub

Private Sub CheckBox1_Change()
    LockFormAspectRatio(Me) = CheckBox1
    Label1 = IIf(LockFormAspectRatio(Me), "* Aspect Ratio: [" & AspectRatio & "]", "")
End Sub
 
Upvote 0
Solution
Thanks again Jaafar, confirm that this works and looks to be more elegant compared to what I had before.
Cheers
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top