The Task
A task I've been given recently is to design a data entry form which transfers data from the form to a table on a worksheet.
Depending on the answers given to various questions, other questions are displayed or hidden. For the most part I've achieved this by using different forms.
There is one route that requires a single form to ask too many questions to sit comfortably on the screen, so on my first build I figured out what I needed and am now working on various refactoring exercises.
What the code does
The class I've written handles the positioning and visibility of frames on the form. Frames added at design time can be moved, hidden or shown without ending up with empty spaces in the middle of the form. It only handles a single column of frames, so haven't added code where two frames might have the same Top value. When the class is initialised it makes a dictionary of all top level (that have the form as a parent) frames on the form.
Set FrameSorter = New cFrameSorter
FrameSorter.Initialise Me
These frames can then be removed or added to the form, where they'll appear beneath the last visible frame. Their position on the form can be moved up, down or to a specified position.
FrameSorter.AddFrame Me.Frame1
FrameSorter.MoveUp Me.Frame1
FrameSorter.Move Me.Frame1, 2
FrameSorter.Remove Me.Frame1
Review
Open to all suggested improvements. Naming conventions, order of procedures, sub, function or property? Should I use an interface (never used one before), any ideas on how to have a subclass looking at frames within frames?
I know I haven't included any error handling yet - it's a first draft, so wanted to see all errors and handle the ones I could.
The Code
To use the code:
- Create a class named
cFrameSorter - Create a userform and add these controls:
- a combobox named
cmbFrames - a texbox named
txtPosition - 5 command buttons named:
cmdMoveFrame,cmdShowFrame,cmdHideFrame,cmdMoveFrameUpandcmdMoveFrameDown. - A few frames. The names don't matter and frames within frames will be ignored. Have a few visible and a few not.
- a combobox named
When the form opens it will populate the combo box with a list of frames - select a frame and click show/hide/up/down or add a number to the text box and click move.
Add this code to the class module:
Option Explicit
'FrameDictionary contains all frames that have the form as the parent.
'VisibleFrames contain all frames within FrameDictionary that have a
'True Visible property in the order they appear.
Private FrameDictionary As Dictionary
Private VisibleFrames As Dictionary
Private pStartPosition As Long
Private pSpacer As Long
Private Sub Class_Initialize()
Set FrameDictionary = New Dictionary
Set VisibleFrames = New Dictionary
Me.StartPosition = 6
Me.Spacer = 10
End Sub
'The position of the first frame on the form.
Public Property Get StartPosition() As Long
StartPosition = pStartPosition
End Property
Public Property Let StartPosition(Value As Long)
pStartPosition = IIf(Value >= 0, Value, 0)
End Property
'This is the distance between frames.
Public Property Get Spacer() As Long
Spacer = pSpacer
End Property
Public Property Let Spacer(Value As Long)
pSpacer = IIf(Value >= 0, Value, 0)
End Property
'This property would not normally exist.
'It exists to populate the combo box on the UserForm.
Public Property Get FrameDict() As Dictionary
Set FrameDict = FrameDictionary
End Property
'Adds a frame to the VisibleFrames dictionary providing
'it exists within the FrameDictionary. The frames Visible
'property is set to TRUE and it will appear beneath
'the last visible frame.
Public Sub AddFrame(SourceFrame As Frame)
If Not SourceFrame Is Nothing Then
If FrameDictionary.Exists(SourceFrame.Name) Then
With SourceFrame
If Not VisibleFrames.Exists(.Name) Then
.Visible = True
VisibleFrames.Add .Name, SourceFrame
ArrangeFrames
End If
End With
End If
End If
End Sub
'The frame is removed from the VisibleFrames dictionary.
'The frames Visible property is set to FALSE and the
'remaining visible frames are rearranged to close any
'gaps left.
Public Sub RemoveFrame(SourceFrame As Frame)
If Not SourceFrame Is Nothing Then
With SourceFrame
If VisibleFrames.Exists(.Name) Then
.Visible = False
VisibleFrames.Remove (.Name)
ArrangeFrames
End If
End With
End If
End Sub
Public Sub MoveUp(SourceFrame As Frame, Optional Position As Long = 1)
Dim lPosition As Long
lPosition = GetPositionInDict(SourceFrame)
If lPosition > 1 Then
MoveFrame SourceFrame, lPosition - 1
ArrangeFrames
End If
End Sub
Public Sub MoveDown(SourceFrame As Frame, Optional Position As Long = 1)
Dim lPosition As Long
lPosition = GetPositionInDict(SourceFrame)
If lPosition > 0 And lPosition < VisibleFrames.Count Then
MoveFrame SourceFrame, lPosition + 1
ArrangeFrames
End If
End Sub
Public Sub Move(SourceFrame As Frame, Position As Long)
MoveFrame SourceFrame, Position
ArrangeFrames
End Sub
'Looks at each frame on the SourceForm. Any that have
'the form as a parent rather than another frame is added
'to the FrameDictionary. These represent the top level frames.
'
'As frames are looked at in the order they were added to the
'form the FrameDictionary is sorted using the Top property of
'each frame.
'
'Any frames with a TRUE visible property at design time are
'added to the VisibleFrames dictionary and are displayed in
'order when the form first opens.
Public Sub Initialise(SourceForm As Object)
Dim ctrl As Control
Dim tmpSubSorter As cFrameSorter
Dim vSortArray As Variant
For Each ctrl In SourceForm.Controls
If TypeName(ctrl) = "Frame" Then
Select Case TypeName(ctrl.Parent)
Case TypeName(SourceForm)
With FrameDictionary
If Not .Exists(ctrl.Name) Then
.Add ctrl.Name, ctrl
End If
End With
Case "Frame"
'Do nothing yet.
End Select
End If
Next ctrl
'Sort the frames contained in the dictionary into
'order based on their Top property.
vSortArray = FrameDictToArray(FrameDictionary)
Sort2DArray vSortArray
SortDictByArray vSortArray, FrameDictionary
'Create a dictionary of visible frames and then
'arrange them on the form in order.
GetVisibleFrames
ArrangeFrames
End Sub
'Returns the ordinal position of a frame within the VisibleFrames dictionary.
'If the frame doesn't exist within the dictionary -1 is returned.
Private Function GetPositionInDict(SourceFrame As Frame) As Long
Dim vItem As Variant
Dim x As Long
If Not SourceFrame Is Nothing Then
If VisibleFrames.Exists(SourceFrame.Name) Then
For Each vItem In VisibleFrames.Items
x = x + 1
If SourceFrame.Name = vItem.Name Then
GetPositionInDict = x
Exit For
End If
Next vItem
Else
GetPositionInDict = -1
End If
End If
End Function
'Populates the VisibleFrames dictionary with frames
'from the FrameDictionary that have a TRUE visible property.
Private Sub GetVisibleFrames()
Dim tmpDict As Dictionary
Dim vItem As Variant
If Not FrameDictionary Is Nothing Then
If FrameDictionary.Count > 0 Then
Set tmpDict = New Dictionary
For Each vItem In FrameDictionary.Items
If vItem.Visible Then
tmpDict.Add vItem.Name, vItem
End If
Next vItem
End If
End If
Set VisibleFrames = tmpDict
End Sub
'Moves a frames position within the VisibleFrames dictionary,
'to a specified position.
'If the required position is higher or lower than the number
'of frames then the highest or lowest value is used.
Private Sub MoveFrame(SourceFrame As Frame, Position As Long)
Dim tmpDict As Dictionary
Dim vItem As Variant
Dim x As Long
If Not SourceFrame Is Nothing Then
Set tmpDict = New Dictionary
SourceFrame.Visible = True
If Not VisibleFrames.Exists(SourceFrame.Name) Then
VisibleFrames.Add SourceFrame.Name, SourceFrame
End If
If Position > VisibleFrames.Count Then
Position = VisibleFrames.Count
ElseIf Position < 0 Then
Position = 0
End If
If Position = VisibleFrames.Count Then
VisibleFrames.Remove SourceFrame.Name
VisibleFrames.Add SourceFrame.Name, SourceFrame
Else
VisibleFrames.Remove SourceFrame.Name
For x = 0 To VisibleFrames.Count - 1
If x = Position - 1 Then
tmpDict.Add SourceFrame.Name, SourceFrame
End If
tmpDict.Add VisibleFrames.Items(x).Name, VisibleFrames.Items(x)
Next x
Set VisibleFrames = tmpDict
End If
End If
End Sub
'Positions the frames contained within the VisibleFrames dictionary on the
'parent form in the order they occur within the dictionary.
Private Sub ArrangeFrames()
Dim vItem As Variant
Dim lTopRow As Long
If Not VisibleFrames Is Nothing Then
If VisibleFrames.Count > 0 Then
lTopRow = Me.StartPosition
For Each vItem In VisibleFrames.Items
vItem.Top = lTopRow
lTopRow = lTopRow + vItem.Height + Me.Spacer
Next vItem
End If
End If
End Sub
'Sorts TargetDict dictionary in the order of the array.
'The vSortArray holds the frame names
Private Sub SortDictByArray(vSortArray As Variant, TargetDict As Dictionary)
Dim tmpDict As Dictionary
Dim vItem As Variant
Dim x As Long
If Not TargetDict Is Nothing Then
If UBound(vSortArray) = TargetDict.Count - 1 Then
Set tmpDict = New Dictionary
For x = LBound(vSortArray) To UBound(vSortArray)
tmpDict.Add vSortArray(x, 1), TargetDict.Item(vSortArray(x, 1))
Next x
Set TargetDict = tmpDict
End If
End If
End Sub
'Takes the frame Top property and frame name to create
'an array from the SourceDictionary items.
Private Function FrameDictToArray(SourceDict As Dictionary) As Variant
Dim tmpDict As Dictionary
Dim x As Long
Dim tmpArr As Variant
Dim itm As Variant
If Not SourceDict Is Nothing Then
If SourceDict.Count > 0 Then
Set tmpDict = New Dictionary
ReDim tmpArr(0 To SourceDict.Count - 1, 0 To 1)
For Each itm In SourceDict.Items
tmpArr(x, 0) = itm.Top
tmpArr(x, 1) = itm.Name
x = x + 1
Next itm
FrameDictToArray = tmpArr
End If
End If
End Function
'Sorts the array using the frames Top property.
Private Sub Sort2DArray(vArray As Variant, _
Optional ByVal lLowStart As Long = -1, _
Optional ByVal lHighStart As Long = -1)
Dim vPivot As Variant
Dim lLow As Long
Dim lHigh As Long
lLowStart = IIf(lLowStart = -1, LBound(vArray), lLowStart)
lHighStart = IIf(lHighStart = -1, UBound(vArray), lHighStart)
lLow = lLowStart
lHigh = lHighStart
vPivot = vArray((lLowStart + lHighStart) \ 2, 0)
While lLow <= lHigh
While (vArray(lLow, 0) < vPivot And lLow < lHighStart)
lLow = lLow + 1
Wend
While (vPivot < vArray(lHigh, 0) And lHigh > lLowStart)
lHigh = lHigh - 1
Wend
If (lLow <= lHigh) Then
Swap vArray, lLow, lHigh
lLow = lLow + 1
lHigh = lHigh - 1
End If
Wend
If (lLowStart < lHigh) Then
Sort2DArray vArray, lLowStart, lHigh
End If
If (lLow < lHighStart) Then
Sort2DArray vArray, lLow, lHighStart
End If
End Sub
Private Sub Swap(vArray As Variant, lItem1 As Long, lItem2 As Long)
Dim vTemp0 As Variant
Dim vTemp1 As Variant
vTemp0 = vArray(lItem1, 0)
vTemp1 = vArray(lItem1, 1)
vArray(lItem1, 0) = vArray(lItem2, 0)
vArray(lItem1, 1) = vArray(lItem2, 1)
vArray(lItem2, 0) = vTemp0
vArray(lItem2, 1) = vTemp1
End Sub
Add this code to the form:
Option Explicit
Private FrameSorter As cFrameSorter
Private Sub UserForm_Initialize()
Dim vItem As Variant
Set FrameSorter = New cFrameSorter
FrameSorter.Initialise Me
'Populate the combobox.
For Each vItem In FrameSorter.FrameDict.Items
Me.cmbFrames.AddItem vItem.Name
Next vItem
End Sub
Private Sub cmdHideFrame_Click()
FrameSorter.RemoveFrame Me.Controls(Me.cmbFrames.Value)
End Sub
Private Sub cmdMoveFrame_Click()
FrameSorter.Move Me.Controls(Me.cmbFrames.Value), CLng(Me.txtPosition)
End Sub
Private Sub cmdMoveFrameDown_Click()
FrameSorter.MoveDown Me.Controls(Me.cmbFrames.Value)
End Sub
Private Sub cmdMoveFrameUp_Click()
FrameSorter.MoveUp Me.Controls(Me.cmbFrames.Value)
End Sub
Private Sub cmdShowFrame_Click()
FrameSorter.AddFrame Me.Controls(Me.cmbFrames.Value)
End Sub
