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.
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.
'
Option Explicit
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
'
Private WithEvents mFrm As Form
'
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 Const PROPS_LENB As Long = 30& ' Not necessarily the same as LenB(muCtrlProps).
Private muCtrlProps As CtrlPropsType
Private msPropsBuff As String ' Initialized in Class_Initialize, so we're not constantly creating/destroying quite so many BSTRs.
'
Private collCtrls As Collection
Private collCtrlExceptions As New Collection ' 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.
'
' Instantiating controls collection to make sure it's a fresh one.
Set collCtrls = New Collection
'
' 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
'
' Populate collection of controls.
Dim ctrl As Control
For Each ctrl In mFrm.Controls
muCtrlProps.ptr = ObjPtr(ctrl)
' Lines are a bit different.
If TypeName(ctrl) = "Line" Then
muCtrlProps.XY = True
muCtrlProps.L = ctrl.X1
muCtrlProps.T = ctrl.Y1
muCtrlProps.W = ctrl.X2
muCtrlProps.H = ctrl.Y2
muCtrlProps.FS = 0&
' Pretty much all else has Left,Top,Width,Height.
Else
muCtrlProps.L = 0&: muCtrlProps.T = 0&: muCtrlProps.W = 0&: muCtrlProps.H = 0&: muCtrlProps.FS = 0&
On Error Resume Next ' Not all controls have all these properties.
muCtrlProps.L = ctrl.Left
muCtrlProps.T = ctrl.Top
muCtrlProps.W = ctrl.Width
muCtrlProps.H = ctrl.Height
muCtrlProps.FS = ctrl.Font.Size
On Error GoTo 0
End If
'
' Move UDT into string, and add to collection.
CopyMemory ByVal StrPtr(msPropsBuff), muCtrlProps, PROPS_LENB
collCtrls.Add msPropsBuff, CStr(ObjPtr(ctrl)) ' Use control's ObjPtr as key.
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
Left = collCtrls(CStr(ObjPtr(ctrl))).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
Else
collCtrls(CStr(ObjPtr(ctrl))).L = NewLeft
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
Top = collCtrls(CStr(ObjPtr(ctrl))).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
Else
collCtrls(CStr(ObjPtr(ctrl))).T = NewTop
End If
mFrm_Resize ' Resize things with this new information.
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
Width = collCtrls(CStr(ObjPtr(ctrl))).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
Else
collCtrls(CStr(ObjPtr(ctrl))).W = NewWidth
End If
mFrm_Resize ' Resize things with this new information.
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
Height = collCtrls(CStr(ObjPtr(ctrl))).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
Else
collCtrls(CStr(ObjPtr(ctrl))).H = NewHeight
End If
mFrm_Resize ' Resize things with this new information.
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
FontSize = collCtrls(CStr(ObjPtr(ctrl))).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
Else
collCtrls(CStr(ObjPtr(ctrl))).FS = NewFontSize
End If
mFrm_Resize ' Resize things with this new information.
End Property
Friend Sub ResizeToOriginal()
' Does as its name suggests.
'mFrm.Move L, T, W, H
mFrm.Move mFrm.Left, mFrm.Top, W, H ' Just resize, no reposition.
End Sub
Friend Sub AddCtrlException(ctrl As Control)
' For "flagging" a control we don't want affected by this resizer.
'
On Error Resume Next ' So we can call it repeatedly on the same control without harm.
collCtrlExceptions.Add 0, CStr(ObjPtr(ctrl)) ' Use control's ObjPtr as key.
On Error GoTo 0
End Sub
Friend Sub DelCtrlException(ctrl As Control)
On Error Resume Next ' So we can call it repeatedly on the same control without harm.
collCtrlExceptions.Remove CStr(ObjPtr(ctrl)) ' Control's ObjPtr is key.
On Error GoTo 0
End Sub
' ******************************************************************
' ******************************************************************
'
' Private from here down.
'
' ******************************************************************
' ******************************************************************
Private Sub Class_Initialize()
' To keep us from constantly creating/destroying strings.
msPropsBuff = String$(PROPS_LENB \ 2&, vbNullChar) ' The \2 is to account for Unicode.
End Sub
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.
'
' 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 iErr As Long: iErr = -1& ' For the case where there aren't any exceptions.
Dim ctrl As Control
Dim v As Variant
Dim iStrPtr As Long
For Each v In collCtrls
'
' Move data into UDT.
CopyMemory iStrPtr, ByVal VarPtr(v) + 8&, 4& ' Get pointer of string reference sitting in variant.
CopyMemory muCtrlProps, ByVal iStrPtr, PROPS_LENB ' Move string's data into UDT.
'
' Make sure it's not in our exceptions list.
If collCtrlExceptions.Count Then ' Just to make it a tad faster when there aren't exceptions.
On Error Resume Next
IsObject collCtrlExceptions.Item(CStr(muCtrlProps.ptr)) ' The actual IsObject function is just used to retrieve the collection. It doesn't matter if it's an object or not.
iErr = Err.Number
On Error GoTo 0
End If
If iErr Then ' If we errored then it's not an exception.
'
' Get the actual control from its ObjPtr.
Set ctrl = Nothing
vbaObjSetAddref ctrl, ByVal muCtrlProps.ptr
'
' Scale the control (and its font).
If muCtrlProps.XY Then
ctrl.X1 = muCtrlProps.L * fScaleW
ctrl.Y1 = muCtrlProps.T * fScaleH
ctrl.X2 = muCtrlProps.W * fScaleW
ctrl.Y2 = muCtrlProps.H * fScaleH
Else
On Error Resume Next ' Not all controls have all these properties.
ctrl.Left = muCtrlProps.L * fScaleW
ctrl.Top = muCtrlProps.T * fScaleH
ctrl.Width = muCtrlProps.W * fScaleW
ctrl.Height = muCtrlProps.H * fScaleH
ctrl.Font.Size = muCtrlProps.FS * fScaleFont
On Error GoTo 0
End If
End If
Next
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.