CallCalled Class Module

CallCalled Class Module

I will be adding information about my “CallCalled” Class Module here, as it becomes available. The most recent example of it is on Access World Forums here:-

VBA to reuse data entry popup form

…         ..         ..            ..        ..          ..           ..     ..  ..         … 

Class Module - Overview

Class Module - Overview

Video 1 (01:09)

You can see how the Class Module provides some excellent functionality for a pop-up form. The class module allows you to grab the Caption of the Calling Control and use it in the caption of the pop-up Form. This means if you call the pop-up form from several different controls. You don’t have to do any coding, it’s all done for you in the class module! The class module allows you to trigger what I call a “Simulated After Update Event”, this means that the calling form, (the one that calls the pop up) can do a calculation as shown in the video. Alternatively in a situation where you were entering dates for a Range, you could check that an “after date” was greater than the “before date”… Another scenario when you are calculating someone’s age, you can automatically do a calculation, display the age immediately! No waiting for the forms on current event to trigger, or some other event to trigger the calculation.

Video 1 (01:09)

Play Video

Video Time Indexes

00:10 The popup calculation form opens, and then you can enter the measurements. 00:16 Once you have gathered the measurements,then the SUM of them is passed back into the Calling Control 00:21 notice that the pop-up Form caption changes depending on which control it is open from. All the coding required to extract the Calling Controls caption is done automatically for you in the CallCalled Class module 00:35 The Class Module also provides the very handy utility of being able to run code on the Calling Form, I don’t believe is available anywhere else! 00:40 I refer to this unique functionality as a Simulated After Update Event

… …

PopUp Forms - Easy!

Heading HERE...

Video 2 (04:49)

In this video I refer to “Magic” — I remember when I first observed this sort of behaviour, the method of transferring information between objects, I was fascinated! I spent a long time working out what happened, and working out how I could use these techniques in my own coding. I must say I am nowhere near a master of it! I hope you find the magic I found, it was one of the main reasons I got involved in producing VBA code, I realise that you could do just about anything with it!

Video 2 (04:49)

Play Video

… …

This is the latest version of the Call Called Class Module. You can paste the code below into a class module in your Microsoft Access database and following the instructions you can use it as is. I also provide a sample database with a working example loading up a calendar form.

Option Compare Database
Option Explicit

'MORE INFO on My Website HERE:-
'http://www.niftyaccess.com/callcalled-class-module/

'*******************************************************************************************************
'*************************************** Declarations Section  *****************************************
'*******************************************************************************************************

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'>>> Database by Tony Hine, alias Uncle Gizmo                                                  <<<
'>>> Created Oct, 2007                                                                         <<<
'>>> Last up-dated March, 2019                                                                 <<<
'>>> Telephone International: +44 7747 018 875                                                 <<<
'>>> Telephone UK: 07747 018 875                                                               <<<
'>>> e-mail: tonyhine@lay-away.co.uk                                                           <<<
'>>> Skype: unclegizmo (I seldom Use Skype)                                                    <<<
'>>> I post at the following forum (mostly) :                                                  <<<
'>>> http://www.access-programmers.co.uk/forums/  (alias Uncle Gizmo)                          <<<
'>>> If my e-mail don't work, try this website: http://www.tonyhine.co.uk/example_help.htm     <<<
'>>> This is my public playground Website for MS Access:-                                      <<<
'>>> The Nifty Access Website is sales orientated:-                                            <<<
'>>> www.niftyaccess.com (A vehicle for me to generate an income from my retirement)           <<<
'>>> My YouTube Channel HERE:- https://www.youtube.com/user/UncleGizmo                         <<<
'>>> CODE SUPPLIED NOT CHECKED AND TESTED FOR ERRORS!!!! Be Warned                             <<<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

'*******************************************************************************************************
'************************************** Recent Searches & Notes ****************************************
'*******************************************************************************************************

'This Class Can be used to return:-
'The Calling Control Name,
'The Principle Control,
'The Parent Form of the Principle Control,
'Principle Control Caption,
'and more

'*******************************************************************************************************
'**************************************** Declared Constants *******************************************
'*******************************************************************************************************
Const conAppName As String = "Nifty Access - clsCallCalled Class"
Const conATH As String = "Database By Tony Hine   Tel: +44 7747 018 875"

'*******************************************************************************************************
'************************ Declare the Private Variable(s) used in this Class ***************************
'*******************************************************************************************************
Private mobjPrincipleCtrl As Object
Private mstrCallingCtrlName As String
Private mstrActiveFormName As String
Private mfrmCallingForm As Form
Private mstrPrincipleCtrlCaption As String
Private mFlgDevMode As Boolean
Private mFlgHASfPassBackRun As Boolean

'*******************************************************************************************************
'********************************* Custom Properties used in this Class ********************************
'*******************************************************************************************************
Property Get prpActiveFormName() As String
    prpActiveFormName = mstrActiveFormName
End Property      'prpActiveFormName Get

Property Get prpCallingCtrlName() As String
    prpCallingCtrlName = mstrCallingCtrlName
End Property      'prpCallingCtrlName Get

Public Property Get prpCallingForm() As Form
    Set prpCallingForm = mfrmCallingForm
End Property      'prpCallingForm Get

Property Set prpPrincipleCtrl(oPassedCtrl As Object)
    Set mobjPrincipleCtrl = oPassedCtrl
End Property      'prpPrincipleCtrl Let

Property Get prpPrincipleCtrl() As Object
   Set prpPrincipleCtrl = mobjPrincipleCtrl
End Property      'prpPrincipleCtrl Get

Property Let prpPrincipleCtrlCaption(strPrincipleCtrlCaption As String)
    mstrPrincipleCtrlCaption = strPrincipleCtrlCaption
End Property      'prpPrincipleCtrlCaption Let

Property Get prpPrincipleCtrlCaption() As String
    prpPrincipleCtrlCaption = mstrPrincipleCtrlCaption
End Property      'prpPrincipleCtrlCaption Get

Property Let prpFlgDevMode(blnFlgDevMode As Boolean)
    mFlgDevMode = blnFlgDevMode
End Property      'prpFlgDevMode Let

Property Get prpFlgDevMode() As Boolean
    prpFlgDevMode = mFlgDevMode
End Property      'prpFlgDevMode Get

Property Let prpFlgHASfPassBackRun(blnFlgHASfPassBackRun As Boolean)
    mFlgHASfPassBackRun = blnFlgHASfPassBackRun
End Property      'prpFlgHASfPassBackRun Let

Property Get prpFlgHASfPassBackRun() As Boolean
    prpFlgHASfPassBackRun = mFlgHASfPassBackRun
End Property      'prpFlgHASfPassBackRun Get

'*******************************************************************************************************
'***************************** Class Initialize Event for this Class ***********************************
'*******************************************************************************************************
Private Sub Class_Initialize()
Dim ctrlActiveControl As Control
Dim strAssociateCtrl As String

    '////////// Show Extra info for the Developer
    prpFlgDevMode = False
    
    Let mstrActiveFormName = Screen.ActiveForm.Name            'Get the Active on the Form (Calling Form)
    
    Set ctrlActiveControl = Screen.ActiveControl                'Get the Control that is Active on the Form.
    
    mstrCallingCtrlName = ctrlActiveControl.Name                'Store the Calling Control Name
    
    Set mfrmCallingForm = fGetParentForm(ctrlActiveControl)     'Store the Form the Control is on, (not always/necessarily the active Form).

'////////// ATH NOTE 2017_05_04 - the "3" in the following line is the prefix length. change it to your prefered coding practice
    strAssociateCtrl = fGetAssociateCtrl(prpCallingForm, prpCallingCtrlName, 3)
    
    Set mobjPrincipleCtrl = prpCallingForm(strAssociateCtrl)                'Store the Principle Control
    
    mstrPrincipleCtrlCaption = fGetLabel(prpCallingForm, prpPrincipleCtrl)  'Store the Principle Control's Label's Caption
    
    Call fHASfPassBackRun           'Check to see if the Routine "fPassBackRun" exists in the Calling form
    
'////////// For Testing - Show the Principle Control's Label's Caption
                If prpFlgDevMode Then
                
                    MsgBox " >>> PrincipleCtrl Caption is:- " & prpPrincipleCtrlCaption, , conAppName
                    
                            If prpFlgHASfPassBackRun Then
                                MsgBox " >>> The Calling Form >>> " & prpCallingCtrlName & _
                                " Contains a Public Function named fPassBackRun (pass-back-run) ", , conAppName
                            Else
                                MsgBox " >>> The Calling Form >>> " & prpCallingCtrlName & _
                                " Does NOT Contain a Public Function named fPassBackRun (pass-back-run) ", , conAppName
                            End If
                End If
End Sub      'Class_Initialize

'*******************************************************************************************************
'****************************** Class Terminate Event for this Class ***********************************
'*******************************************************************************************************
Private Sub Class_Terminate()
    Set mobjPrincipleCtrl = Nothing
    Set mfrmCallingForm = Nothing
End Sub      'Class_Terminate

'*******************************************************************************************************
'*********************** Public Subroutines and Functions used in this Class ***************************
'*******************************************************************************************************
Public Function fActiveFormLoaded() As Boolean
Dim strSubName As String
Dim strModuleName As String

strSubName = "fActiveFormLoaded"
strModuleName = "Module - clsCallCalled"

On Error GoTo Error_Handler
        'From:-
        'https://docs.microsoft.com/en-us/office/vba/api/access.accessobject.isloaded
        If CurrentProject.AllForms(prpActiveFormName).IsLoaded Then
            fActiveFormLoaded = True
        Else
            MsgBox "The Active Form has been unexpectedly closed. One solution to this problem is to make the Pop-Up form Modal", , conAppName
        End If

Exit_ErrorHandler:
    
    Exit Function

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
        
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
            
            Select Case Err.Number
                Case 0.123 'When Required, Replace Place Holder (0.123) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Function      'fActiveFormLoaded

'*******************************************************************************************************
'********************** Private Subroutines and Functions used in this Class ***************************
'*******************************************************************************************************
Private Function fGetParentForm(ctrlActiveControl As Control) As Form
Dim strSubName As String
Dim strModuleName As String

strSubName = "fGetParentForm"
strModuleName = "Module - clsCallCalled"

On Error GoTo Error_Handler

        Dim ctlToTest As Control
        Set ctlToTest = ctrlActiveControl        'Will Always be a "Control? No Not always... "
'/////////// CHECK THIS ...No Not always...
        Dim X As Integer
        
            For X = 1 To 20 'This will check to 20 levels
                If Not fParentIsaForm(ctlToTest.Parent.Name) Then   'Is Parent a Form?
                'It's not a form, so it must still be a control so carry on checking a "Control"
                    Set ctlToTest = ctlToTest.Parent                'No --- Then check the next Parent
                Else
                'It is a form, so you have found the form that the control is on.
                    Set fGetParentForm = ctlToTest.Parent  'Yes -- Then Set the Property to The Parent Form
                    Exit For
                End If
            Next X
            
    'I cannot foresee a situation with more than 20 levels, but I thought a check on it would be wise
    If X >= 20 Then MsgBox "Message from clsCallCalled ---" & "ERROR 20 Levels EXCEEDED, change 20 to a higher Figure ---", , conAppName
'////////// For Testing -
    If prpFlgDevMode Then MsgBox "Level Checked to is :- " & X & " Level(s)", , conAppName

Exit_ErrorHandler:
    
    Exit Function

Error_Handler:
    Dim strErrFrom As String
    Dim strErrInfo As String
        
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
            
            Select Case Err.Number
                Case 1 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Function      'fGetParentForm

Private Function fParentIsaForm(strIsaForm As String) As Boolean
'From Access Help
'https://msdn.microsoft.com/en-us/library/office/ff822456.aspx
fParentIsaForm = False
    Dim obj As AccessObject, dbs As Object
    Set dbs = Application.CurrentProject
    ' Search for open AccessObject objects in AllForms collection.
        For Each obj In dbs.AllForms
            If obj.Name = strIsaForm Then fParentIsaForm = True
        Next obj
End Function      'fParentIsaForm

Private Function fGetAssociateCtrl(frmCallingForm As Form, strActiveCtrlName As String, intPrefixLen As Integer) As String
'Looks for any Control with the same name, makes sure there's only one control, and returns that control.

Dim strNamePart As String
strNamePart = Right(strActiveCtrlName, Len(strActiveCtrlName) - intPrefixLen)   'The active control name without the prefix
                                                                                'Length of prefix determined by:- intPrefixLen
                                                                                'Prefix Removed (Naming Convention)
Dim strFoundControlName As String

Dim Ctrl As Control
Dim X As Integer

    For Each Ctrl In frmCallingForm
        Select Case Ctrl.ControlType
            Case acComboBox, acTextBox, acLabel ', acCommandButton ', acCheckBox, acListBox, acOptionButton, acOptionGroup, acToggleButton
            
            If strActiveCtrlName <> Ctrl.Name Then 'Skip if it's the same Control
                If Right(Ctrl.Name, Len(Ctrl.Name) - intPrefixLen) = strNamePart Then
                    X = X + 1
                    strFoundControlName = Ctrl.Name
                End If
            End If
            
        End Select
    Next Ctrl

Dim strCtrlToUse As String

    Select Case X
        Case Is = 0     'No Associate Control Found
            strCtrlToUse = strActiveCtrlName
'////////// For Testing -
            If prpFlgDevMode Then MsgBox "NO ASS CTRL", , conAppName
                
        Case Is = 1     'One Associate Control Found
            strCtrlToUse = strFoundControlName
        Case Is > 1     'More than one Associate Control Found
            MsgBox "From Function: fGetAssociateCtrl in the Form: frmExample. More than " & _
            "one Control Found with the Same Name. The Control " & Chr(34) & strActiveCtrlName & Chr(34) & _
            " will be made the Principle Control. Correct the Conflicting names to Continue.", , conAppName
            
            strCtrlToUse = strActiveCtrlName
            
        Case Else
            MsgBox "From Function: fGetAssociateCtrl in the Form: frmExample. Unforeseen " & _
            "Error in Case Statement. The Control " & Chr(34) & strActiveCtrlName & Chr(34) & _
            " will be made the Principle Control. Please find the Fault before Continuing.", , conAppName
            
            strCtrlToUse = strActiveCtrlName
    
    End Select
    
fGetAssociateCtrl = strCtrlToUse

End Function      'fGetAssociateCtrl

Private Function fHasLabel(oFormPassed As Form, strCtrlName As String) As Boolean
'This function Returns True if the control "Name" entered has an associated label.
'Used in "fGetLabel"

Dim Ctrl As Control

    For Each Ctrl In oFormPassed
      If Ctrl.ControlType = acLabel Then
          If Ctrl.Parent.Name = strCtrlName Then fHasLabel = True
       End If
    Next
      
End Function      'fHasLabel

Private Function fGetLabel(oFormPassed As Form, oCtrl As Control) As String
'Extract the caption from the Associate Controls label...

        If fHasLabel(oFormPassed, oCtrl.Name) Then
            fGetLabel = oCtrl.Controls(0).Caption
        Else
            fGetLabel = ""
        End If

End Function      'fGetLabel

Private Sub fHASfPassBackRun()
'Test to see if the function "fPassBackRun" (Pass-back-run) exists in the Calling Form
'If it does then sets the property "prpFlgHASfPassBackRun" to true.

Dim strSubName As String
Dim strModuleName As String

strSubName = "fHASfPassBackRun"
strModuleName = "Module - clsCallCalled"

On Error GoTo Error_Handler

    prpFlgHASfPassBackRun = True
    'Call the Function fPassBackRun to Test to see if it Exists
    prpCallingForm.fPassBackRun ("# ~ Never Use this in the fPassBackRun Case Statement #~#~3£&8*  ")
    'If the Function fPassBackRun does not exist it Triggers Error 2465 which is handled below

Exit_ErrorHandler:

    Exit Sub

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
        
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
            
            Select Case Err.Number
                Case 2465 'Application-defined or object-defined error
                    'UnCheck This Message for Testing
                    'MsgBox "Error Caused because - fPassBackRun does not exist" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                    prpFlgHASfPassBackRun = False   'Flag that the Function fPassBackRun does not exist
                    Err.Number = 0                  'An Expected Error, - so Reset
                    Resume Next                     'Resume as if no Error Occured
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Sub      'fHASfPassBackRun