jwcolby
jwcolby at colbyconsulting.com
Tue Oct 27 21:39:06 CDT 2009
And the supervisor. Again very similar except that the entire control scanner is in this class now.
that method is really the only tricky part. Where the control was not directly in the form I had
to index into the colClsCtlsSorted using Ctl.Parent.Parent.name. The parent is the page and the
parent.parent is the tab.
'
'clsCtlSortSupervisor2
'
Option Compare Database
Option Explicit
Private colClsCtlsSorted As Collection
Private Sub Class_Initialize()
Set colClsCtlsSorted = New Collection
End Sub
Private Sub Class_Terminate()
Set colClsCtlsSorted = Nothing
End Sub
Function mInit(frm As Form)
mScanFormForSections frm
mSortcontrols
End Function
'
'Return the entire collection of all instances of clsCtlSorted
'
Property Get colClsControlsSorted() As Collection
Set colClsControlsSorted = colClsCtlsSorted
End Property
'
'Return a clsCtlSorted instance for a specific object (tab, form section etc)
'
'strObjName is the name of the tab page, control section etc.
'
Function cControlsSorted(strObjName As String) As clsCtlsSorted
On Error Resume Next
Set cControlsSorted = colClsCtlsSorted(strObjName)
End Function
'
'Returns a string of all controls and what object they belong to
'
'---------------------------------------------------------------------------------------
' Procedure : pCtlNames
' Author : jwcolby
' Date : 10/27/2009
' Purpose :
'---------------------------------------------------------------------------------------
'
Property Get pCtlNames() As String
Dim lclsCtlsSorted As clsCtlsSorted2
Dim strCtlNames As String
On Error GoTo Err_pCtlNames
For Each lclsCtlsSorted In colClsCtlsSorted
strCtlNames = strCtlNames & lclsCtlsSorted.pCtlNames() & vbCrLf
Next lclsCtlsSorted
pCtlNames = strCtlNames
Debug.Print strCtlNames
Exit_pCtlNames:
On Error Resume Next
Exit Property
Err_pCtlNames:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_pCtlNames
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Property
'
'The class factory createa an instance of clsCtlsSorted,
'passing in the name of the object in the form
'that contained the controls collection
'
'After the class is instantiated and initialized,
'the instance is stored in colClsCtlsSorted
'keyed on the name of the object that contained the controls collection
'
'---------------------------------------------------------------------------------------
' Procedure : mClassFactory
' Author : jwcolby
' Date : 10/27/2009
' Purpose :
'---------------------------------------------------------------------------------------
'
Private Function mClassFactory(lstrObjName As String)
Dim lclsCtlsSorted As clsCtlsSorted2
On Error GoTo Err_mClassFactory
Set lclsCtlsSorted = New clsCtlsSorted2
lclsCtlsSorted.mInit lstrObjName
colClsCtlsSorted.Add lclsCtlsSorted, lstrObjName
Exit_mClassFactory:
On Error Resume Next
Exit Function
Err_mClassFactory:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mClassFactory
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
'
'Sections can contain tabs
'which contain pages which contain controls
'
'---------------------------------------------------------------------------------------
' Procedure : mScanSectionForControls
' Author : jwcolby
' Date : 10/27/2009
' Purpose :
'---------------------------------------------------------------------------------------
'
Function mScanSectionForControls(sec As Section)
Dim ctl As Control
Dim lclsSectionCtlsSorted As clsCtlsSorted2 '
Dim lclsTabPgCtlsSorted As clsCtlsSorted2
Dim intTabIndex As Integer 'Dim a variable to use to generate an error if the control does
NOT have a tabindex property
Dim ctlParent As Control 'Dim a variable to test whether the parent is a control
On Error GoTo Err_mScanSectionForControls
Set lclsSectionCtlsSorted = colClsCtlsSorted(sec.Name) 'Pull the instance for the section
For Each ctl In sec.Controls 'Iterate the section's contyrol collection
On Error Resume Next
intTabIndex = ctl.TabIndex 'Test for the TabIndex property
If Err = 0 Then 'If no error then process control (store in the collection)
Debug.Print sec.Name & ":" & ctl.Name & "::" & ctl.Parent.Name
If ctl.ControlType = acTabCtl Then 'Look for tab controls
lclsSectionCtlsSorted.mAddCtl ctl 'Place this control in the sections class
instance
mScanTabForPages ctl
Else
Err.Clear
Set ctlParent = ctl.Parent
If Err = 0 Then 'this control is on another control so store in the right
class instance
On Error GoTo Err_mScanSectionForControls
Set lclsTabPgCtlsSorted = colClsCtlsSorted(ctlParent.Parent.Name & "." &
ctlParent.Name)
lclsTabPgCtlsSorted.mAddCtl ctl
Else
On Error GoTo Err_mScanSectionForControls
lclsSectionCtlsSorted.mAddCtl ctl 'this control is directly in the section so
store in that instance
Err.Clear
End If
End If
Else
Err.Clear
End If
Next ctl
Exit_mScanSectionForControls:
On Error Resume Next
Exit Function
Err_mScanSectionForControls:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
' Case 91 'Class not instantiated
' mClassFactory ctlParent.Parent.Name & "." & ctlParent.Name
' Resume 0
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mScanSectionForControls
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
'
'Find all pages of a tab control
'
Function mScanTabForPages(ctlTab As Control)
Dim pg As page
For Each pg In ctlTab.Pages 'Iterate the page collection
mClassFactory ctlTab.Name & "." & pg.Name 'Get an instance of lclsCtlsSorted
for the page
Next pg
End Function
'
'Finds every section of a form
'Having found any valid section, it creates an
'instance of clsCtlsSorted for that section
'
'---------------------------------------------------------------------------------------
' Procedure : mScanFormForSections
' Author : jwcolby
' Date : 10/26/2009
' Purpose :
'---------------------------------------------------------------------------------------
'
Function mScanFormForSections(frm As Form)
Dim sec As Section
Dim intSection As Integer
On Error GoTo Err_mScanFormForSections
On Error Resume Next
For intSection = 0 To 4 'There are only 5 sections in a form
Set sec = frm.Section(intSection) 'Test to see if the section exists
If Err = 0 Then 'The section exists so
On Error GoTo Err_mScanFormForSections
mClassFactory sec.Name 'Get an instance of lclsCtlsSorted
mScanSectionForControls sec 'Now scan the section for tab controls
Else
Err.Clear
End If
Next intSection
Exit_mScanFormForSections:
On Error Resume Next
Exit Function
Err_mScanFormForSections:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mScanFormForSections
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
Function mSortcontrols()
Dim lclsCtlsSorted As clsCtlsSorted2
For Each lclsCtlsSorted In colClsCtlsSorted
lclsCtlsSorted.mSortcontrols
Next lclsCtlsSorted
End Function
John W. Colby
www.ColbyConsulting.com
A.D.Tejpal wrote:
> JC,
>
> Thanks for providing a nice class based solution so promptly. Your well
> known command over classes deserves to be complimented.