Resize userform using API - maintain proportion

F

Formula11

Active Member
Joined
Mar 1, 2005
Messages
493
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
 
Sort by date Sort by votes
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.
Click to expand...
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
You must log in or register to reply here.

Similar threads

C
  • Question Question
Userform that always stays on top but allows interacting with forms behind it
Replies
5
Views
203
Logit
Logit
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
2K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
1K
Jaafar Tribak
Jaafar Tribak
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
891
huiettcm
H
R
  • Solved
Resizing Userforms in 64-bit excel
Replies
5
Views
3K
mwoollen
M

Share this page

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