| '---------------------------------------------------------------------
' Begin of Class Module: clsAutoSize
Option Explicit
Private Declare Function CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (dest As Any, src As Any, ByVal length As Long) _
As Long
Private WithEvents m_frmParent As Form 'The parent form to watch
Private Type SizeAndPos ' Used to track the size and position of
LocLeft As Single ' child controls
LocTop As Single
SizeWidth As Single
SizeHeight As Single
FontSize As Single
End Type
Private m_colOrig As Collection ' Collection of sizes for controls,
' actually contains a string for each control that's passed through
' PackUDT/UnPackUDT to see its values
Private m_sizeOrig As SizeAndPos 'The size of the parent form
Private m_nLastPercX As Double ' Last percentage of change of the
Private m_nLastPercY As Double ' parent form, initially 1.0
Private Function PackUDT(tmp As SizeAndPos) As String
' PackUDT and UnPackUDT are a little cheat to copy UDT's to and
' from strings. This makes it possible to stuff the UDTs into a
' collection, without having to use a dummy class
PackUDT = Space(Len(tmp))
CopyMemory ByVal PackUDT, tmp, Len(tmp)
End Function
Private Sub UnPackUDT(tmp As SizeAndPos, sIn As String)
CopyMemory tmp, ByVal sIn, Len(tmp)
End Sub
Public Sub Initialize(frmParent As Form)
' Initialize all the member variables
m_nLastPercX = 1
m_nLastPercY = 1
Set m_colOrig = New Collection
Set m_frmParent = frmParent
Dim ctrl As Control
Dim tmp As SizeAndPos
Dim sTemp As String
On Error Resume Next
' Loop through each control in the controls on the parent form,
' and record the starting size and position. Making sure to
' handle controls that don't have a property, such as FontSize.
For Each ctrl In m_frmParent.Controls
' Since tmp is used in each iteration, make sure and reset it
' to sane values before using it again
tmp.LocLeft = 0
tmp.LocTop = 0
tmp.SizeHeight = 0
tmp.SizeWidth = 0
tmp.FontSize = 0
' Attempt to read each property, if there's an error,
' just put -1 in the UDT
Err.Clear
tmp.LocLeft = ctrl.Left
If Err Then
tmp.LocLeft = -1
Err.Clear
End If
tmp.LocTop = ctrl.Top
If Err Then
tmp.LocTop = -1
Err.Clear
End If
tmp.SizeHeight = ctrl.Height
If Err Then
tmp.SizeHeight = -1
Err.Clear
End If
tmp.SizeWidth = ctrl.Width
If Err Then
tmp.SizeWidth = -1
Err.Clear
End If
tmp.FontSize = ctrl.FontSize
If Err Then
tmp.FontSize = -1
Err.Clear
End If
'Store the UDT for later use
m_colOrig.Add PackUDT(tmp), NameOfControl(ctrl)
Next
'Make note of the form's starting size
m_sizeOrig.FontSize = m_frmParent.FontSize
m_sizeOrig.SizeHeight = m_frmParent.Height
m_sizeOrig.SizeWidth = m_frmParent.Width
End Sub
Private Function NameOfControl(ByVal ctrl As Control) As String
' Simple little function that returns the name of a control,
' adding on the index of the control if it has one. Used as
' the key in m_colOrig
On Error Resume Next
NameOfControl = "Control:" & ctrl.Name
NameOfControl = NameOfControl & ":"
NameOfControl = NameOfControl & Format(ctrl.Index)
If Err Then
Err.Clear
NameOfControl = NameOfControl & "-1"
End If
End Function
Private Sub m_frmParent_Resize()
' Because m_frmParent is declared WithEvents, this will get
' called when the parent form is resized, just like Form_Resize
If m_frmParent.WindowState = vbMinimized Then
'Don't do anything if the form is minimized
Exit Sub
End If
Dim nPercX As Double
Dim nPercY As Double
Dim tmp As SizeAndPos
Dim sTemp As String
Dim ctrl As Control
' What's the percentage of change from the original?
nPercX = m_frmParent.Width / m_sizeOrig.SizeWidth
nPercY = m_frmParent.Height / m_sizeOrig.SizeHeight
' If the percentage of change exactly matches the last seen
' values, don't bother to do anything
If nPercX = m_nLastPercX And nPercY = m_nLastPercY Then
Exit Sub
End If
m_nLastPercX = nPercX
m_nLastPercY = nPercY
On Error Resume Next
' Loop through each of the controls, and change it's size and
' position to mirror the new size of the form. Gracefully handle
' controls that have appeared since we initialized, or controls
' that can't be moved or resized for whatever reason.
For Each ctrl In m_frmParent.Controls
Err.Clear
sTemp = m_colOrig.Item(NameOfControl(ctrl))
If Err Then
Err.Clear
Else
UnPackUDT tmp, sTemp
If tmp.FontSize <> -1 Then
' Font size is an odd one. Should we use the percentage of
' change for the width or the height? I decided to simply
' ues the lesser, whichever that may be, but the situtation
' might call for something different.
ctrl.FontSize = tmp.FontSize * _
IIf(nPercX < nPercY, nPercX, nPercY)
End If
' Here we're protected by an On Error, so if the property
' is not -1, just try to change it, if it fails, nothing
' we can do, so simply move on to the next property.
If tmp.LocLeft <> -1 Then
ctrl.Left = tmp.LocLeft * nPercX
End If
If tmp.LocTop <> -1 Then
ctrl.Top = tmp.LocTop * nPercY
End If
If tmp.SizeHeight <> -1 Then
ctrl.Height = tmp.SizeHeight * nPercY
End If
If tmp.SizeWidth <> -1 Then
ctrl.Width = tmp.SizeWidth * nPercX
End If
End If
Next
End Sub
' End of Class Module: clsAutoSize
'---------------------------------------------------------------------
|
| Option Explicit
Private m_AutoSize As clsAutoSize
Private Sub Form_Load()
' To fully appreciate this example, place a good number of controls on
' the example form, and after it's loaded and running, resize the form.
Set m_AutoSize = New clsAutoSize
m_AutoSize.Initialize Me
End Sub
|