Updates:
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:
And that's it!
Here's the code in the Resizer.cls module, for those who may want to stare at it before downloading.
---------------
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.
March 21, 2024:
* Fixed problem with minimizing & maximizing.
* Replaced collections with arrays, and fixed all the "Helper" functions.
March 20, 2024:
* Initial release.
* Fixed problem with minimizing & maximizing.
* Replaced collections with arrays, and fixed all the "Helper" functions.
March 20, 2024:
* Initial release.
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:
Code:
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
Here's the code in the Resizer.cls module, for those who may want to stare at it before downloading.
Code:
'
' 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.