Form & Controls Resizer (including Font.Size)

[Elroy]

Updates:

March 21, 2024:
* Fixed problem with minimizing & maximizing.
* Replaced collections with arrays, and fixed all the "Helper" functions.
March 20, 2024:
* Initial release.

Notice: I looked into making this thing work with MDIChild forms, but VB6 does some very bizarre resizing with these MDIChild forms. To make it work, it would vastly increase the complexity of this thing, and I just didn't want to do that. So, no MDIChild forms.

Ok, yeah, this has been done a couple of times before. But I've never been happy with what's out there. So here's my version.



There's a sample project with everything in it. But I'm going through it here anyway.

I've tried to make this as simple to use as possible (and also as fast as possible). It's all in one class module, with no references at all. To use it, here's all that's needed in a form:

Option Explicit
'
Dim Resizer As New Resizer
'


Private Sub Form_Load()
    Resizer.Init Me ' Just before user has an opportunity to resize the form.

    ' The rest of your Form_Load code.


End Sub

And that's it!

Here's the code in the Resizer.cls module, for those who may want to stare at it before downloading.

'
' Usage:
'
'   Put the following line at the top (just under Option Explicit) of your Form's code:
'
'           Dim Resizer As New Resizer
'
'   Then, in your Form_Load event, place the following code:
'
'           Resizer.Init Me
'
'   And that's it.  Your form should now resize all its controls when it's resized.
'   If you dynamically (during runtime) add any controls, just call "Resizer.Init Me" again.
'   Also, if you dynamically remove any controls, also call "Resizer.Init Me" again.
'   You can call it as many times as you like, but be frugal.
'
'   There are some "helper" properties in case you change any Left, Top, Width, Height,
'   or Font.Size of the form or controls dynamically (with code).  These "helper"
'   properties are seen below and are as follows:
'
'           Property Get/Let Left(Optional ctrl As Control) [ = NewLeft ]
'           Property Get/Let Top(Optional ctrl As Control) [ = NewTop ]
'           Property Get/Let Width(Optional ctrl As Control) [ = NewWidth ]
'           Property Get/Let Height(Optional ctrl As Control) [ = NewHeight ]
'           Property Get/Let FontSize(Optional ctrl As Control) [ = NewFontSize ]
'
'   If the ctrl isn't specified, it's assumed you want the form's properties.
'   Again, if you're changing these in code, if you use these "helper" properties,
'   this resizer will continue to work and reflect those changes.
'   Don't forget to specify the Resizer object when calling these properties.
'
'   And a couple more "helper" procedures:
'
'           Sub ResizeToOriginal()                  ' To put form back to its original size.
'           Sub AddCtrlException(ctrl As Control)   ' To prevent certain controls from resizing.
'           Sub DelCtrlException(ctrl As Control)   ' To remove from above exception list.
'           Sub ForceResize()                       ' Just a way to "force" a resize with the form its current size.
'
Option Explicit
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (a() As Any) As Long
Private Declare Sub SafeArrayAllocDescriptor Lib "OleAut32" (ByVal cDims As Long, ByRef psaInOut As Long)
'
Private WithEvents mFrm As Form
Private miPrevWindowState As Long
'
Private L    As Single    ' Original for the form.
Private T    As Single    ' Original for the form.
Private W    As Single    ' Original for the form.
Private H    As Single    ' Original for the form.
Private FS   As Currency  ' Original for the form.
'
' UDT for Original Control properties we're saving.
Private Type CtrlPropsType
    ptr  As Long        ' The control's ObjPtr.
    ' No need to worry about the control's index of a control array.
    L    As Single      ' We just take whatever scalemode we get.
    T    As Single      ' We just take whatever scalemode we get.
    W    As Single      ' We just take whatever scalemode we get.
    H    As Single      ' We just take whatever scalemode we get.
    FS   As Currency    ' Font.Size.
    XY   As Boolean     ' Basically, whether or not it's a "Line" control.
End Type
'
Private muCtrls()           As CtrlPropsType    ' Original control properties.
Private miExceptions()      As Long             ' For ones that are NOT to be resized.
'

Friend Sub Init(frm As Form)
    ' This must be called (preferrably in Form_Load) before the user has an opportunity to resize the form.
    ' This "Init" can be called multiple times, specifically if we change a Font.Size or move any of
    ' the controls around via code.  Also, if any controls are dynamically (during runtime) added.
    '
    ' But preferrably, the coder will call the "helper" functions herein to change these things.
    '
    ' Make sure initializations are done.
    SafeArrayAllocDescriptor 1&, ByVal ArrPtr(muCtrls())
    '
    ' Save reference to form's object.
    Set mFrm = frm
    '
    ' Save form's properties.
    L = mFrm.Left
    T = mFrm.Top
    W = mFrm.Width
    H = mFrm.Height
    FS = mFrm.Font.Size
    '
    ' Make sure we've got more to do.
    If mFrm.Controls.Count = 0& Then Exit Sub
    '
    ' Dimension our controls array.
    ReDim muCtrls(mFrm.Controls.Count - 1&)
    '
    ' Populate collection of controls.
    Dim idx As Long
    Dim ctrl As Control
    For Each ctrl In mFrm.Controls
        muCtrls(idx).ptr = ObjPtr(ctrl)
        ' Lines are a bit different.
        If TypeName(ctrl) = "Line" Then
            muCtrls(idx).XY = True
            muCtrls(idx).L = ctrl.X1
            muCtrls(idx).T = ctrl.Y1
            muCtrls(idx).W = ctrl.X2
            muCtrls(idx).H = ctrl.Y2
            muCtrls(idx).FS = 0&
        ' Pretty much all else has Left,Top,Width,Height.
        Else
            On Error Resume Next ' Not all controls have all these properties.
                muCtrls(idx).L = ctrl.Left
                muCtrls(idx).T = ctrl.Top
                muCtrls(idx).W = ctrl.Width
                muCtrls(idx).H = ctrl.Height
                muCtrls(idx).FS = ctrl.Font.Size
            On Error GoTo 0
        End If
        idx = idx + 1&
    Next
End Sub


' ******************************************************************
' ******************************************************************
'
'   Some "helper" procedures.
'   Not necessarily needed for basic resizing to work.
'   But, if you want to dynamically (with code) change
'   the form's Width, Height, or Font.Size, or any of the
'   control's Left, Top, Width, Height, or Font.Size, it's
'   best to use these so the resizing will continue to work
'   correctly.
'
' ******************************************************************
' ******************************************************************


Friend Property Get Left(Optional ctrl As Control) As Single
    ' Returns the "Original" (just after compiling) property.
    ' Scalemode is whatever the user set.
    ' If the ctrl isn't passed, the form's FontSize is returned.
    ' If the control is a control array, just pass the specific control of the array you're interested in.
    '
    If ctrl Is Nothing Then
        Left = L
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then Left = muCtrls(idx).L
    End If
End Property

Friend Property Let Left(Optional ctrl As Control, NewLeft As Single)
    ' For changing the "Original" value from code (not the same as a "resized" value).
    '
    If ctrl Is Nothing Then
        L = NewLeft
        mFrm.Left = L ' Don't need to resize.
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then
            muCtrls(idx).L = NewLeft
            mFrm_Resize ' Resize things with this new information.
        End If
    End If
End Property

Friend Property Get Top(Optional ctrl As Control) As Single
    ' Returns the "Original" (just after compiling) property.
    ' Scalemode is whatever the user set.
    ' If the ctrl isn't passed, the form's Left is returned.
    ' If the control is a control array, just pass the specific control of the array you're interested in.
    '
    If ctrl Is Nothing Then
        Top = T
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then Top = muCtrls(idx).T
    End If
End Property

Friend Property Let Top(Optional ctrl As Control, NewTop As Single)
    ' For changing the "Original" value from code (not the same as a "resized" value).
    '
    If ctrl Is Nothing Then
        T = NewTop
        mFrm.Top = T ' Don't need to resize.
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then
            muCtrls(idx).T = NewTop
            mFrm_Resize ' Resize things with this new information.
        End If
    End If
End Property

Friend Property Get Width(Optional ctrl As Control) As Single
    ' Returns the "Original" (just after compiling) property.
    ' Scalemode is whatever the user set.
    ' If the ctrl isn't passed, the form's Width is returned.
    ' If the control is a control array, just pass the specific control of the array you're interested in.
    '
    If ctrl Is Nothing Then
        Width = W
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then Width = muCtrls(idx).W
    End If
End Property

Friend Property Let Width(Optional ctrl As Control, NewWidth As Single)
    ' For changing the "Original" value from code (not the same as a "resized" value).
    '
    If ctrl Is Nothing Then
        W = NewWidth
        mFrm_Resize ' Resize things with this new information.
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then
            muCtrls(idx).W = NewWidth
            mFrm_Resize ' Resize things with this new information.
        End If
    End If
End Property

Friend Property Get Height(Optional ctrl As Control) As Single
    ' Returns the "Original" (just after compiling) property.
    ' Scalemode is whatever the user set.
    ' If the ctrl isn't passed, the form's Height is returned.
    ' If the control is a control array, just pass the specific control of the array you're interested in.
    '
    If ctrl Is Nothing Then
        Height = H
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then Height = muCtrls(idx).H
    End If
End Property

Friend Property Let Height(Optional ctrl As Control, NewHeight As Single)
    ' For changing the "Original" value from code (not the same as a "resized" value).
    '
    If ctrl Is Nothing Then
        H = NewHeight
        mFrm_Resize ' Resize things with this new information.
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then
            muCtrls(idx).H = NewHeight
            mFrm_Resize ' Resize things with this new information.
        End If
    End If
End Property

Friend Property Get FontSize(Optional ctrl As Control) As Currency
    ' Returns the "Original" (just after compiling) property.
    ' If the ctrl isn't passed, the form's FontSize is returned.
    ' If the control is a control array, just pass the specific control of the array you're interested in.
    '
    If ctrl Is Nothing Then
        FontSize = FS
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then FontSize = muCtrls(idx).FS
    End If
End Property

Friend Property Let FontSize(Optional ctrl As Control, NewFontSize As Currency)
    ' For changing the "Original" value from code (not the same as a "resized" value).
    '
    If ctrl Is Nothing Then
        FS = NewFontSize
        mFrm_Resize ' Resize things with this new information.
    Else
        Dim idx As Long
        idx = CtrlArrayIdx(ObjPtr(ctrl))
        If idx >= 0& Then
            muCtrls(idx).FS = NewFontSize
            mFrm_Resize ' Resize things with this new information.
        End If
    End If
End Property

Friend Sub ResizeToOriginal()
    ' Does as its name suggests.
    'mFrm.Move L, T, W, H
    If mFrm.WindowState <> vbNormal Then mFrm.WindowState = vbNormal
    miPrevWindowState = vbMaximized     ' This helps with a timing issue.
    mFrm.Move mFrm.Left, mFrm.Top, W, H ' Just resize, no reposition.
End Sub

Friend Sub ForceResize()
    ' There shouldn't ever be a need to call this, as it's all automatic.
    ' However, I supply this method anyway.
    ' All it does is force-call the internal mFrm_Resize event.
    '
    mFrm_Resize
End Sub

Friend Sub AddCtrlException(ctrl As Control)
    ' For "flagging" a control we don't want affected by this resizer.
    '
    ' Make sure we're not adding a duplicate.
    Dim idx As Long
    For idx = LBound(miExceptions) To UBound(miExceptions)
        If miExceptions(idx) = ObjPtr(ctrl) Then Exit Sub
    Next
    '
    ' Create space.
    If UBound(miExceptions) = -1& Then
        ReDim miExceptions(0&)
    Else
        ReDim Preserve miExceptions(UBound(miExceptions) + 1&)
    End If
    '
    ' Save this exception.
    miExceptions(UBound(miExceptions)) = ObjPtr(ctrl)
End Sub

Friend Sub DelCtrlException(ctrl As Control)
    Dim idx As Long
    For idx = LBound(miExceptions) To UBound(miExceptions)
        If miExceptions(idx) = ObjPtr(ctrl) Then
            Dim jdx As Long
            For jdx = idx + 1& To UBound(miExceptions)
                miExceptions(jdx - 1&) = miExceptions(jdx)
            Next
            If UBound(miExceptions) = 0& Then
                Erase miExceptions
                SafeArrayAllocDescriptor 1&, ByVal ArrPtr(miExceptions())
            Else
                ReDim Preserve miExceptions(UBound(miExceptions) - 1&)
            End If
            Exit Sub
        End If
    Next
    ' If we don't find it, just fall out.
End Sub


' ******************************************************************
' ******************************************************************
'
'       Private from here down.
'
' ******************************************************************
' ******************************************************************


Private Sub Class_Initialize()
    SafeArrayAllocDescriptor 1&, ByVal ArrPtr(muCtrls())
    SafeArrayAllocDescriptor 1&, ByVal ArrPtr(miExceptions())
End Sub

Private Function CtrlArrayIdx(iObjPtr As Long) As Long
    ' This is a bit slow, and could be converted to a sort & binary search,
    ' but it's just used in the "helper" functions, so we're fine.
    '
    Dim idx As Long
    CtrlArrayIdx = -1& ' Default for not found.
    For idx = LBound(muCtrls) To UBound(muCtrls)
        If muCtrls(idx).ptr = iObjPtr Then
            CtrlArrayIdx = idx
            Exit Function
        End If
    Next
End Function

Private Sub mFrm_Resize()
    ' This is raised AFTER the Form_Resize, and that's what we want.
    ' That way, if anything is moved around in the Form_Resize,
    ' it'll get correctly resized by this procedure.
    '
    ' Don't do it if we're minimizing.
    If mFrm.WindowState = vbMinimized Then Exit Sub
    '
    ' Calculate scaling.
    Dim fScaleW As Single
    Dim fScaleH As Single
    Dim fScaleFont As Single
    fScaleW = mFrm.Width / W
    fScaleH = mFrm.Height / H
    If fScaleW < fScaleH Then fScaleFont = fScaleW Else fScaleFont = fScaleH
    '
    ' Scale the form's font.
    On Error Resume Next
        mFrm.Font.Size = FS * fScaleFont
    On Error GoTo 0
    '
    ' Loop to go through all the "known" controls of this form, and resize them.
    Dim ctrl    As Control
    Dim idx     As Long
    For idx = LBound(muCtrls) To UBound(muCtrls)
        '
        ' Make sure it's not in our exceptions list.
        Dim edx     As Long
        Dim bExcept As Boolean
        bExcept = False
        For edx = LBound(miExceptions) To UBound(miExceptions)
            If miExceptions(edx) = muCtrls(idx).ptr Then
                bExcept = True
                Exit For
            End If
        Next
        If Not bExcept Then
            '
            ' Get the actual control from its ObjPtr.
            Set ctrl = Nothing
            vbaObjSetAddref ctrl, ByVal muCtrls(idx).ptr
            '
            ' Scale the control (and its font).
            If muCtrls(idx).XY Then
                ctrl.X1 = muCtrls(idx).L * fScaleW
                ctrl.Y1 = muCtrls(idx).T * fScaleH
                ctrl.X2 = muCtrls(idx).W * fScaleW
                ctrl.Y2 = muCtrls(idx).H * fScaleH
            Else
                On Error Resume Next ' Not all controls have all these properties.
                    ctrl.Left = muCtrls(idx).L * fScaleW
                    ctrl.Top = muCtrls(idx).T * fScaleH
                    ctrl.Width = muCtrls(idx).W * fScaleW
                    ctrl.Height = muCtrls(idx).H * fScaleH
                    ctrl.Font.Size = muCtrls(idx).FS * fScaleFont
                On Error GoTo 0
            End If
        End If
    Next
    '
    ' We have trouble coming back from maximized (or a "ResizeToOriginal"),
    ' so we sleep a moment and do it again (recurse once).
    If miPrevWindowState = vbMaximized Then
        miPrevWindowState = mFrm.WindowState
        Sleep 100&
        mFrm_Resize
    Else
        miPrevWindowState = mFrm.WindowState
    End If
End Sub

---------------

Just to say it, someone may have a custom User Control (UC) with several internal controls. In that case, this resizer isn't going to resize those internal controls, but it will resize the overall UC. However, for those designing UCs, they should typically put their own resizing code inside that UC, so all should be copacetic.

Enjoy.

[yokesee]

Very good work.
I have some problems when I maximize the window and restore it again it looks bad.
All the best

[Elroy]

Very good work.
I have some problems when I maximize the window and restore it again it looks bad.
All the best

Ohhh, I didn't think of that. I've also got a problem with the included "helper" procedures. I'll get an update out here soon.

[yokesee]

It works very well.

I have some controls that freeze a lot when I resize.
How could the solution be, just change the size when you release the mouse click.
Is it possible to do this.
All the best

[Elroy]

It works very well.

I have some controls that freeze a lot when I resize.
How could the solution be, just change the size when you release the mouse click.
Is it possible to do this.
All the best

Is it possible for you to post this FRM (and FRX) file so I can see what's going on here?

[yokesee]

sorry I forgot to say.
They are third party controls.
They are not optimized and when the size is changed they update
interface and if you do it too many times it freezes.
Sorry I can't put code.

[Elroy]

sorry I forgot to say.
They are third party controls.
They are not optimized and when the size is changed they update
interface and if you do it too many times it freezes.
Sorry I can't put code.

Yokesee, sorry but I'm not going to be able to debug third-party controls like this. And, the way you describe it, it sounds like it's a problem with those controls. I'm not sure what "update interface" means, but that sounds dubious.

Good luck with your project.

Just as an FYI, if they were well-known controls (such as RTB for example), I'd be able to take a look. But not knowing anything about them, who knows what they're doing. That's one reason that I adamantly refuse to use any third-party controls these days unless I've also got the source code (or maybe if they're Microsoft controls).

[zx81sp]

How it works in MDI forms? I've tested it in an old app that use vkUserControlsXP and MDI forms and fails but I guess is not (only) for the control and when the MDI child loads it does not fit to the MDI windows, the class try to resize it to the screen size (has sense since it's maximized, but inside the MDI not in the screen).

[Elroy]

How it works in MDI forms? I've tested it in an old app that use vkUserControlsXP and MDI forms and fails but I guess is not (only) for the control and when the MDI child loads it does not fit to the MDI windows, the class try to resize it to the screen size (has sense since it's maximized, but inside the MDI not in the screen).

Hi zx81sp,

Yeah, I thought about MDI forms. However, since I virtually never use them (not even for the IDE's windows), I didn't do any testing with them.

But, when I get some time, I'll test and see if there's an easy fix for making them work with MDI forms. I suspect there is, especially since I'm keeping a reference to the form being resized. I'm not basing anything off of the "screen" size though, so it's a bit puzzling to me why it's not working. But again, I'll take a look.

[zx81sp]

Hi zx81sp,

Yeah, I thought about MDI forms. However, since I virtually never use them (not even for the IDE's windows), I didn't do any testing with them.

But, when I get some time, I'll test and see if there's an easy fix for making them work with MDI forms. I suspect there is, especially since I'm keeping a reference to the form being resized. I'm not basing anything off of the "screen" size though, so it's a bit puzzling to me why it's not working. But again, I'll take a look.

I've don't take a deep look to your code but I guess it's related to the form window state. The MDI child is usually in maximized state and it appears to be resized to the screen resolution, not the resolution of its container.

Anyway the class hangs with MDI forms. I've added to your project a MDI form, convert form1 to a child, works of if I resize the child form, hangs when I maximize the child form (same as in my app). Attached example.


Resizer_mdi.zip

[Elroy]

Ok, after more testing, it's clear that VB6 is doing some very bizarre resizing things with MDI-Child forms. To make this resizer logic work with them would require jumping through some hoops I'm just not willing to jump through. The main reason is, it would vastly increase the complexity of this thing. And, I'm not sure MDI-Child forms should have a lot of controls on them anyway, and the ones they do have probably don't need to be resized.

So, no MDI-Child forms. I've put this notice on the OP as well.

[Adebiyi24]

Elroy
thanks for this valuable work
I have tested your code and it is working perfect except on one form where I 'm saving and loading control position in database.
In form load event, If I place Load_FrmSettings after Resizer.Init Me, the new form settings are not loaded.
If I place Load_FrmSettings after Resizer.Init Me, the controls and fonts looks weired.
thamk you again

[Elroy]

Please show some pictures.

Also, you may need to move the loading of your settings to the Form_Activate event, possibly creating a Boolean flag to indicate whether or not it's already been done.