LEARN MS-ACCESS TIPS AND TRICKS

Streamline Zoom-in Control Data Editing

a.p.r. pillaiMarch 29, 2024 No comments

Streamlining Form Module Code in Standalone Class Module.

Editing Large Text Box Contents in Zoom-in Control.

This topic was originally published in August 2007 under the title ‘Edit Data in Zoom-in Control.’ In that example, a custom shortcut menu was created and linked to the form to activate the zoom-in control, allowing users to edit the textbox contents containing multiple lines of data, similar to the Notes field in the Employees table.

The earlier version of the customized Shortcut Menu for the Employees Form is shown below for reference.

Right-click to open Large Image in New Tab/Window.

The built-in Shortcut Menu was customised by designing a new button image, highlighted in the Form image by a red oval shape. This button, resembling a CRT screen, is programmed with the necessary code to execute on clicking. However, designing a new button image within the existing shortcut menu is very difficult.

Opening the Zoom Control is a two-step process: first, right-click the TextBox to display the Shortcut Menu, then select the Zoom option to open the Zoom-in Form with the active TextBox Contents.

Now, we have a more efficient method: simply right-click on a TextBox to open the Zoom-in Form prefilled with its data. After editing the contents, click the [Save] command button on the Zoom Form to update the original TextBox with the revised text.

The New Version of Zoom-in Form Image.

The New Employees Form with the Zoom-in Control with the Notes Field Data is given below:

Right-click to open Large Image in New Tab/Window.

In addition to copying the data from the Employees Notes TextBox into the larger TextBox on the Zoom Form, the formatting attributes from the original TextBox on the Employees Form are also applied, ensuring consistency in appearance.

The Main Public Functions.

There are two Public Functions that run this procedure.

The ZoomOpen() Function.

Public Function ZoomOpen()
'------------------------------------------------------
'Function : Edit Data in Zoom-in Control.
'Author   : a.p.r.pillai
'Date     : 29/07/2007, 26/03/2024
'Rights(c): www.msaccesstips.com
'------------------------------------------------------
Dim varVal, ctl As Control, intFontWeight As Integer
Dim strFont As String, intFontSize As Integer
Dim boolFontstyle As Boolean
Dim lngfontColor As Long, boolFontUnderline As Boolean
Dim bkgColor As Long

On Error GoTo ZoomOpen_Err

Set ctl = Screen.ActiveControl
With ctl
   strFont = .FontName
   intFontSize = .FontSize
   intFontWeight = .FontWeight
   boolFontstyle = .FontItalic
   boolFontUnderline = .FontUnderline
   lngfontColor = .ForeColor
   'bkgColor = .BackColor
End With

   varVal = Screen.ActiveControl.Value
   DoCmd.OpenForm "Zoom", acNormal

With Screen.ActiveForm.Controls("TxtZoom")
   .Value = varVal
   .FontName = strFont
   .FontSize = intFontSize
   .FontWeight = intFontWeight
   .FontItalic = boolFontstyle
   .FontUnderline = boolFontUnderline
   .ForeColor = lngfontColor
   '.BackColor = bkgColor
End With

ZoomOpen_Exit:
Exit Function

ZoomOpen_Err:
Resume ZoomOpen_Exit
End Function

When you right-click a TextBox, the ZoomOpen() function is executed. It copies the TextBox contents into a Variant variable, opens the Zoom-in Form, and transfers the data into the larger TextBox. The original formatting attributes from the source text box are also applied to ensure the text appears the same in the Zoom-in TextBox.

After editing the text in the Zoom-in control, click the [Save] Command Button to save the changes into the original text box of the Employees Form, and close the Zoom-in Form.

The Zoom-in Form can be dragged and moved to a convenient position in the Application Window. The Zoom Form will open in Popup and Modal Mode, and you must close it to access other controls or Forms.

The SaveZoomData() Function.

The [Save] Command Button Click Runs the SaveZoomData() Function. The VBA Code is given below.

Public Function SaveZoomData()
'------------------------------------------------------
'Function : Save Edited Data in the Control
'Author   : a.p.r.pillai
'Date     : 29/07/2007, 26/03/2024
'Rights(c): www.msaccesstips.com
'------------------------------------------------------
Dim vartxtZoom, strControl As String

On Error GoTo SaveZoomData_Err

 vartxtZoom = Forms("Zoom").Controls("txtZoom").Value

 DoCmd.Close acForm, "zoom"
 
 If Screen.ActiveControl.Locked = True Then
   strControl = Screen.ActiveControl.Name
   MsgBox strControl & " is Read-Only, Changes discarded!"
   Exit Function
 Else
    If IsNull(vartxtZoom) = False And Len(vartxtZoom) > 0 Then
        Screen.ActiveControl.Value = vartxtZoom
    End If
 End If
 
SaveZoomData_Exit:
Exit Function

SaveZoomData_Err:
Resume SaveZoomData_Exit
End Function

The SaveZoomData() Function saves the edited data into its Source TextBox. If the Textbox is locked, the edited data cannot be saved.

In both the above Functions, we used the Screen Object to address the active Form or active Text Box control without using their object names directly, e.g., Screen.ActiveForm, Screen.ActiveControl that has the Focus.

As I stated earlier, all you need to do is right-click on the TextBox to open the Zoom-in control and present the TextBox contents in the Zoom Window for editing.

For those who prefer a shortcut menu to open the Zoom Control, I created a small macro-based menu that can be assigned to the Form Shortcut Menu Bar property or to the same property of any individual control on the Form. When applied at the Form level, the shortcut menu will appear whenever you right-click anywhere on the Form, not just on a specific control such as a TextBox. The Macro Shortcut Menu Options.

There are two Shortcut Menu options to display in the Macro.

Open Zoom
Cancel

The macro Commands for the Shortcut Menu Bar are listed in the McrZoom Macro Image shown below:

Right-click to open Large Image in New Tab/Window.

The macro shown above provides two options. The first option runs the ZoomOpen() function, which opens the Zoom Form and loads the text from the active TextBox into the Zoom Control for editing. The second option simply cancels the right-click event.

2. Create the Menu Macro.

We need to create a Menu Macro and insert the Menu Options Macro McrZoom.

The Menu Macro Image is given below:

Right-click to open a Large Image in New Tab/Window.

The Menu Macro name is McrControlShortcut.

The 'Shortcut Menu Bar' Property of Form and Controls.

The Menu Macro can be inserted into the Shortcut Menu Bar Property of the Form or in the same Property of the Controls on the Form.

When added to the Form Property, the Menu appears wherever you right-click on the Form. When added to a specific Control's Shortcut Menu Bar Property, the Menu appears for that Control.

Most controls on the form have the 'Shortcut Menu Bar' property, allowing you to insert a menu macro name to display the shortcut menu. When inserted into the TextBox's property, you can even right-click on the child label of the TextBox to bring up the shortcut menu.

Normally, in the OnClick Event Property of a Command Button or a TextBox, we can insert a Macro or a Public Function Name that executes when it receives a Mouse Button Click.

Despite the 'Shortcut Menu Bar' property expecting a menu bar, it directly executes the macro or function name inserted into this property when the control receives a Right-click Event. Additionally, it briefly displays a small empty menu bar.

Examples:

Text0.Shortcut Menu Bar = "Macro2"
Text0.Shortcut Menu Bar = "=ZoomOpen()"

We will experiment with both methods. Created the Macro Menu as above for easy implementation as well.

In this round of streamlining VBA code, we do not employ any object-level wrapper classes. Instead, we use only the interface class Cls_ObjInit, which we can experiment with both approaches for utilizing the Zoom control.

The Zoom Form with txtZoom TextBox.

The Zoom Form Image is given below for Reference.

Right-click to open a large image in New Tab/Window.

The Zoom Form has two Command Buttons. One to save the edited data into its Source Textbox, and the other to cancel the operation. Both Command Button Click Subroutines are written in the Form Module.

Option Compare Database
Option Explicit

Private Sub cmdSave_Click()
  Call SaveZoomData
End Sub

Private Sub cmdCancel_Click()
  DoCmd.Close acForm, "Zoom"
End Sub

The Interface Class Module Cls_ObjInit

Option Compare Database
Option Explicit

Private frm As Access.Form

Public Property Get m_Frm() As Form
  Set m_Frm = frm
End Property

Public Property Set m_Frm(ByRef vForm As Form)
  Set frm = vForm
  
  Call Class_Init
End Property

Private Sub Class_Init()
Dim opt As String

opt = "McrControlShortcut"

'opt = "=ZoomOpen()" 'Call Function directly on Right-Click

frm.ShortcutMenu = True 'True by default
Call SetupControls(opt)
       
End Sub

Private Sub SetupControls(ByVal strOpt As String)
Dim ctl As Control

For Each ctl In frm.Controls
  Select Case ctl.ControlType
Case acTextBox
    'ctl.ShortcutMenuBar = StrOpt 'For all TextBoxes
            
      Select Case ctl.Name 'Only selected TextBoxes
          Case "Title", "Address", "Notes"
          
            ctl.ShortcutMenuBar = strOpt
            
      End Select

  End Select
Next
End Sub

Private Sub Class_Terminate()
Dim opt As String

opt = ""
Call SetupControls(opt)

End Sub

The Cls_ObjInit interface class declares a Form object in the global area, followed by the property procedures for handling the Form.

After receiving the active Form object through the frm property, the Class_Init() subroutine is executed. Both Class_Init() and Class_Terminate() call the common SetUpControls() subroutine. This routine is responsible for either assigning the macro-based shortcut menu to the Shortcut Menu Bar property of the Employees Form or directly invoking the ZoomOpen() function.

The Class_Terminate() subroutine resets the Shortcut Menu Bar property, ensuring that changes made by the standalone class module Cls_ObjInit are applied dynamically.

With a small adjustment to the Class_Init() subroutine, you can configure the Shortcut Menu Bar property either for all TextBoxes (or any other control) on the Form or a specific one.

The Trial Runs.

In the Class_Init() subroutine, we plan to call the SetUpControls() subroutine to dynamically configure the Shortcut Menu Bar property of the TextBox controls. To better understand its behavior, we will experiment with two alternate settings, applying them one at a time. This trial approach allows us to observe how each configuration affects the functionality of the Zoom Control feature.

opt = "McrControlShortcut"

'opt = "=ZoomOpen()" 'Call Function directly on Right-Click

frm.ShortcutMenu = True 'True by default

By default, the second line of code is kept disabled. Remember that the setting frm.ShortcutMenu = True is the default for the form. If the shortcut menu does not appear as expected, check this property in the form and correct it.

Before invoking the SetUpControls() subroutine, the parameter variable Opt is initialized with the macro menu name "McrControlShortcut". The subroutine then assigns this macro name to the TextBox control’s Property Shortcut Menu Bar. When this option is active, right-clicking the TextBox displays the custom shortcut menu. Choosing “Open Zoom” from the menu runs the public function: ZoomOpen(), while the “Cancel” option simply cancels the right-click action.

When the second option in the Class_Init() subroutine is enabled, the right-click event bypasses the macro and executes the ZoomOpen() function.

Similarly, the SetUpControl() subroutine has two options. The default method assigns the Shortcut Menu Bar property only to selected TextBox controls where data is likely to exceed the visible boundary. In this example, the fields include Title, Address, and Notes. Additional fields can be included as needed, depending on the requirements.

If we plan to implement it on all the TextBoxes on the Form, then the 'ctl.ShortcutMenuBar = StrOpt can be enabled, and the following lines of VBA Code can be removed.

      Select Case ctl.Name 'Only selected TextBoxes
          Case "Title", "Address", "Notes"
          
            ctl.ShortcutMenuBar = strOpt
            
      End Select

The Employees Form Module VBA Code.

Option Compare Database
Option Explicit

Dim Cl As New Cls_ObjInit

Private Sub Form_Load()
Set Cl.m_Frm = Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set Cl = Nothing
End Sub

The Interface Class Cls_ObjInit is declared and instantiated in the global declaration area of the Employees Form. In the Form_Load() Event Procedure, the Current Form Object is passed to the Form Property Procedure, and from there the Class_Init() Subroutine is called to set the Shortcut Menu Bar Property of the TextBoxes in the Employees Form.

This trick also works on the Tabular and Datasheet Forms. Two Demo Forms, Tabular and Datasheet Employee Forms, are also provided in the Demo Database.

Download the Demo Database.

DataEditing Zoom-in Control.zip

Streamlining Code Reminder Popup Form

a.p.r. pillaiMarch 19, 2024 No comments

Streamlining Form Module Code in Standalone Class Module.

Reminder Popup Form.

Understanding the significance of reminders is paramount. When it comes to important occasions such as a family member's or a friend's birthday, adequate preparation time is crucial. Being notified at least two days beforehand, we don't overlook these events amidst our busy schedules and other pressing commitments.

When considering business-related activities, let's examine the Inventory System's advance notification of the Pharmacy's re-order status as an example. It's imperative to print a list of medicines that fall below the minimum stock level or reach reorder levels on the 25th of each month to facilitate stock replenishment by placing orders in advance.

Seasonal demand requires higher stock levels of certain medicines during winter. By reviewing usage patterns from previous years, we can identify high-demand medicines and place advance orders with suppliers to ensure adequate availability before the season begins.

Tasks that require advanced alerts or scheduled notifications can be programmed to trigger a pop-up form or report with the relevant information, ensuring timely attention and prompt action. The Birthday Experiment.

Here, we will demonstrate this feature using the Employees table, which has been extended with two additional fields: BirthDate and BFlag. The BirthDate field contains the assumed date of birth for each employee. For calculation purposes, the day and month of birth are combined with the current year (e.g., 14-March-1961 becomes 14-March-2024) to determine the birthdate. The logical field BFlag is updated to True once the birthday greeting has been printed from the alert pop-up form.

The Alerts are programmed to run in three stages:

A pop-up form appears 48 hours before the individual's birthday and recurs again on the eve of the celebration.
The pop-up form will display on the birthday when the database is accessed. A straightforward birthday greeting card in PDF format is generated directly from the pop-up. Upon completing the card printing process, the Employees Table field BFlag is marked to True, ensuring that the pop-up won't reappear during subsequent database openings.
If the Birthday Greetings are not printed and the BFlag Field is not set to True, then the alert pop-up will appear for the next two days after the due date, indicating overdue case(s).

Initially, we establish an input Query named Birthday_RemData that includes a new column to record each employee's birthdate for the Current Year, sourced from the actual BirthDate field in the Employees1 table. The Birthday_RemData Query is the foundational dataset for categorizing data into the above three categories for pop-up forms.

The Employees1 Table Image.

The Employees1 Table image is shown below, with the required Fields for ready reference.

Reminder: Data Filtering Queries.

The SQL of the Input Query, with the current year Date of Birth, is calculated for each Employee, from the actual Date of Birth in the Table given below:

Query Name: BirthDay_RemData (Birthday Reminder Input Data).

SELECT Employees1.EmployeeID, 
[FirstName] & " " & [LastName] AS Name, 
Employees1.BirthDate, 
Employees1.BFlag, 
DateDiff("yyyy",[birthdate],Date()) AS Age, 
DateValue(Format([BirthDate],"dd/mm") & "-" & CStr(Year(Date()))) AS DueDate
FROM Employees1;

1. Query: RemindQ1_OnDate - to filter data for the Popup on the actual BirthDay:

SELECT BirthDay_RemData.*
FROM BirthDay_RemData
WHERE (((BirthDay_RemData.DueDate)=Date()) AND ((BirthDay_RemData.BFlag)=False));

2. Query: RemindQ2_Advance - to filter data for the Popup that appears two days before the BirthDay:

SELECT BirthDay_RemData.*
FROM BirthDay_RemData
WHERE (((BirthDay_RemData.BFlag)=False) AND (([DueDate]-1)=Date()))
OR (((BirthDay_RemData.BFlag)=False) AND (([DueDate]-2)=Date()));

3. Query: RemindQ3_OverDue - to filter data for the Popup that appears two days after the BirthDay, if the birthday card is not printed on the Birthday.:

SELECT BirthDay_RemData.*
FROM BirthDay_RemData
WHERE (((BirthDay_RemData.BFlag)=False) AND (([DueDate]+1)=Date())) 
OR (((BirthDay_RemData.BFlag)=False) AND (([DueDate]+2)=Date()));

The RemindQ1_OnDate Query is the source Data of the Reminder1 Popup Form. The Reminder2 and Reminder3 Forms are linked to the RemindQ2_Advance and RemindQ3_Overdue Queries, respectively. All three are Tabular Forms.

Reminder: POPUP Forms.

1. The Reminder1 Popup Form Image is given below for reference.

The employee records with birthdays matching today’s date will be displayed on the Form, showing their actual date of birth and the birthday for the current year in separate columns. You can print the greeting card by clicking the “Print PDF Greeting” Command Button. The default path of the greeting’s target location can be temporarily altered directly in the text box. You can make the change permanent in the Default Value Property of the text box in the design view.

The Advance and Overdue Reminder Popups may show differently in Day/Month in both columns. The Printing option is not available in the Advanced and Overdue Popup Forms Footer Section.

The Greetings PDF file will be saved to the path indicated in the TextBox in the Footer Section of the Form. The path displayed in the TextBox is set in the TextBox Default Value Property, which you can modify to save it to your preferred path.

The Sample Greetings Card.

The sample Greetings Card image is given below for reference.

The other two Popup Form Images are given below for information.

2. Alert about upcoming Birthdays:

3. Alerts about the missed Birthday Celebrations:

How do the Popup Form(s) open automatically if the Employee's Date of Birth meets any of the criteria specified above?

It is easy; when the database is open, it checks for records in the three Queries (i.e., RemindQ1_OnDate, RemindQ2_Advance, and RemindQ3_OverDue) and opens the Alert Form linked to the Queries. For this purpose, a small Function is created in the Standard Module.

The VBA Code of the Checkpopup() Function.

Public Function Checkpopup()
'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================
Dim i, j, k As Integer
i = DCount("*", "RemindQ1_OnDate")
If i > 0 Then
    DoCmd.OpenForm "Reminder1", acNormal
End If

j = DCount("*", "RemindQ2_Advance")
If j > 0 Then
    DoCmd.OpenForm "Reminder2", acNormal
End If

k = DCount("*", "RemindQ3_OverDue")
If k > 0 Then
    DoCmd.OpenForm "Reminder3", acNormal
End If

End Function

Running the Popup Forms.

Now all we need to do is call this Function immediately after opening the Database. The first choice to create a Macro named AutoExec (the Auto Execute Macro) and call the Function using the RunCode Command. The name of the Macro must be AutoExec to run immediately when the Database is open. Another option is to drag this Macro, place it on the Desktop as a Shortcut. Double-click on it to open the Database and run the Macro.

Another option is to run the Function from the Form_Load() Event Subroutine of the first Form that opens when the database is open.

If there is no urgency, call the Function when the Employees Form is open; then PopUp Form(s) will appear if any of the three data-filtering Queries, or all of them, have data after a brief 3-second delay.

This is good for experimenting with this trick and learning to devise a better method for Advanced Alerts, on-the-day or Overdue Alerts in your other Projects.

The Employee Form-based Popup.

There are three employee Forms for each Reminder category. All of them can be opened from a small Main Form. The Image of the Main Form is given below.

The Employees Form Image of the First Option:

When you open this Form, there is a delay of about 3 seconds; the Reminder1_OnDate Popup Form will open with the Employees' Records having their BirthDate today. If there are no records, the [Open Reminder] Command Button is disabled. If the pop-up doesn't appear, change the BirthDate of one or two employees to match the Day and Month (don't change the year) to match the current Date.

If you close the Reminder Form by mistake, use the CommandButton that opens the Reminder Form.

There are two other Forms for experimenting with Reminders of forthcoming or overdue Reminder setups.

Streamlining VBA Event Subroutine Codes.

Now coming to the Streamlined VBA Coding Part, there are three Employee Forms with two CommandButtons. The Employee information is for display purposes only. If you plan to edit the employee's Birthdate through this Form, you are welcome, but the validation check is not performed, and full responsibility is yours. All three Forms are linked to the same Employees1 Table.

Since all three forms have two command buttons each, we need only one CommandButton Wrapper Class to handle the Events of Command Button Clicks. But we will use three different Class_Init() Interface Classes (Intermediary Class) to create separate Instances for all three Employee Forms, so that their Identity References will remain separately in memory. The 3-second TimerInterval running Subroutine is also run from within this Class Module and then opens the Popup Form.

The Command Button Wrapper Class: Rm1_cmdButton - Employee Forms.

 
Option Compare Database
Option Explicit

Private WithEvents cmd As Access.CommandButton
Private mfrm As Form
Dim t As Integer
'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================

Public Property Get m_Frm() As Access.Form
  Set m_Frm = mfrm
End Property

Public Property Set m_Frm(ByRef vfrm As Access.Form)
  Set mfrm = vfrm
End Property

Public Property Get m_cmd() As Access.CommandButton
  Set m_cmd = cmd
End Property

Public Property Set m_cmd(ByRef vcmd As Access.CommandButton)
  Set cmd = vcmd
End Property

Private Sub cmd_Click()
  Select Case cmd.Name
    Case "cmdReminder1"
        DoCmd.OpenForm "Reminder1", acNormal
    Case "cmdReminder2"
        DoCmd.OpenForm "Reminder2", acNormal
    Case "cmdReminder3"
        DoCmd.OpenForm "Reminder3", acNormal
        
    Case "cmdExit1"
        DoCmd.Close acForm, "Employees1"
    Case "cmdExit2"
        DoCmd.Close acForm, "Employees2"
    Case "cmdExit3"
        DoCmd.Close acForm, "Employees3"
  End Select
End Sub

We need only one Click-Event Subroutine in the Class Module to handle the Command Button Clicks from all three Forms. The Code is not messy and remains clean and directly accessible, rather than through the Form Design View. The Event Procedure Code is self-explanatory.

Three different Interface Class Modules for different Employee Forms. We don't create Instances of the Interface Class. Hence, we need to create three different Interface Classes. Moreover, it runs the TimerInterval Subroutine for three different Forms.

Interface Class of Employees1 Form: Rm1_Init Class VBA Code.

 Option Compare Database
Option Explicit

Private cmd As Rm1_CmdButton
Private WithEvents frm As Form

Private Coll As New Collection
Dim t As Integer

'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================

Public Property Get m_Frm() As Form
  Set m_Frm = frm
  
End Property

Public Property Set m_Frm(ByRef vfrm As Form)
  Set frm = vfrm
  
  Call Class_Init
  
End Property

Private Sub Class_Init()
Dim ctl As Control
Const EP = "[Event Procedure]"

frm.OnTimer = EP

For Each ctl In frm.Controls
    Select Case TypeName(ctl)
        Case "CommandButton"
          Select Case ctl.Name
            Case "cmdReminder1", "cmdExit1"
            Set cmd = New Rm1_CmdButton
            Set cmd.m_Frm = frm
            Set cmd.m_cmd = ctl
                cmd.m_cmd.OnClick = EP
                Coll.Add cmd
            Set cmd = Nothing
          End Select
    End Select
Next

t = 0
frm.TimerInterval = 1000
End Sub

Private Sub frm_Timer()
Dim icount As Long
On Error GoTo frmTimer_Err

t = t + 1
If t = 3 Then
    frm.TimerInterval = 0
icount = DCount("*", "RemindQ1_OnDate")
    If icount > 0 Then
        t = 0
        frm.cmdReminder1.Enabled = True
        Call PopupOpen("Reminder1")
    Else
        frm.cmdReminder1.Enabled = False
        frm.Requery
    End If
End If

frmTimer_Exit:
Exit Sub

frmTimer_Err:
MsgBox Err.Description, , "frmTimer()"
Resume frmTimer_Exit
End Sub

Private Sub Class_Terminate()
Do While Coll.Count > 0
    Coll.Remove 1
Loop

End Sub

This class module is declared within the Employee1 Form Module, where a reference to the Employee1 form is passed to the `frm` object. The `Class_Initialize` procedure is then invoked. At the beginning of this procedure, the Employee1 Form's Timer event is enabled, followed by the creation of Command Button instances and the initialization of their event handling procedures.

The Timer Interval is set to 1000 milliseconds (1 second), and the Timer event runs for three consecutive intervals (3 seconds). After this 3-second delay, the record count of the `ReminderQ1_OnDate` query is retrieved. If the record count is greater than 0, the `Reminder1_OnDate` popup form is opened to display the corresponding reminder records.

Interface Class of Employees2 Form: Rm2_Init Class.

Option Compare Database
Option Explicit

Private cmd As Rm1_CmdButton
Private WithEvents frm As Form

Private Coll As New Collection
Dim t As Integer
'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================

Public Property Get m_Frm() As Form
  Set m_Frm = frm
  
End Property

Public Property Set m_Frm(ByRef vfrm As Form)
  Set frm = vfrm
  
  Call Class_Init
  
End Property

Private Sub Class_Init()
Dim ctl As Control
Const EP = "[Event Procedure]"

frm.OnTimer = EP

For Each ctl In frm.Controls
    Select Case TypeName(ctl)
        Case "CommandButton"
          Select Case ctl.Name
            Case "cmdReminder2", "cmdExit2"
            Set cmd = New Rm1_CmdButton
            Set cmd.m_Frm = frm
            Set cmd.m_cmd = ctl
                cmd.m_cmd.OnClick = EP
                Coll.Add cmd
            Set cmd = Nothing
          End Select
    End Select
Next

t = 0
frm.TimerInterval = 1000
End Sub

Private Sub frm_Timer()
Dim icount As Long
On Error GoTo frmTimer_Err

t = t + 1
If t = 3 Then
    frm.TimerInterval = 0
icount = DCount("*", "RemindQ2_Advance")
    If icount > 0 Then
        t = 0
        frm.cmdReminder2.Enabled = True
        frm.Requery
  
        Call PopupOpen("Reminder2")
    Else
        frm.cmdReminder2.Enabled = False
        frm.Requery
    End If
End If

frmTimer_Exit:
Exit Sub

frmTimer_Err:
MsgBox Err.Description, , "frmTimer()"
Resume frmTimer_Exit
End Sub

Private Sub Class_Terminate()
Do While Coll.Count > 0
    Coll.Remove 1
Loop

End Sub

The only difference in this Module is the query name and CommandButton Names. We use the same Rm1_CmdButton Wrapper Class.

Rm3_Init Interface Class also has the same VBA Code with different Query and Command Button Names.

Option Compare Database
Option Explicit

Private cmd As Rm1_CmdButton
Private WithEvents frm As Form

Private Coll As New Collection
Dim t As Integer
'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================

Public Property Get m_Frm() As Form
  Set m_Frm = frm
  
End Property

Public Property Set m_Frm(ByRef vfrm As Form)
  Set frm = vfrm
  
  Call Class_Init
  
End Property

Private Sub Class_Init()
Dim ctl As Control
Const EP = "[Event Procedure]"

'frm.OnTimer = EP

For Each ctl In frm.Controls
    Select Case TypeName(ctl)
        Case "CommandButton"
          Select Case ctl.Name
            Case "cmdReminder3", "cmdExit3"
                Set cmd = New Rm1_CmdButton
                Set cmd.m_Frm = frm
                    cmd.m_Frm.OnTimer = EP
                Set cmd.m_cmd = ctl
                    cmd.m_cmd.OnClick = EP
                    Coll.Add cmd
            Set cmd = Nothing
        End Select
    End Select
Next

t = 0
frm.TimerInterval = 1000

End Sub

Private Sub frm_Timer()
Dim icount As Long
'On Error GoTo frmTimer_Err

t = t + 1
If t = 3 Then
    frm.TimerInterval = 0
  icount = DCount("*", "RemindQ3_OverDue")
    If icount > 0 Then
        t = 0
        frm.cmdReminder3.Enabled = True
        frm.Requery
  
        Call PopupOpen("Reminder3")
    Else
        frm.cmdReminder3.Enabled = False
        frm.Requery
    End If
End If

frmTimer_Exit:
Exit Sub

frmTimer_Err:
MsgBox Err.Description, , "frmTimer()"
Resume frmTimer_Exit
End Sub

Private Sub Class_Terminate()
Do While Coll.Count > 0
    Coll.Remove 1
Loop

End Sub

The Popup Forms' Wrapper Class and Interface Class Module VBA Code.

Only one Wrapper Class Module and one Interface Class are required for all three Popup Forms to handle the Event Procedures of Command Buttons. All three Forms have only Command Button click events handled in the Wrapper Class Sub_CmdButton and Interface Class Module.

The Sub_CmdButton Wrapper Class Module VBA Code.

Option Compare Database
Option Explicit

Private WithEvents cmd As Access.CommandButton
Private frm As Form
'========================================================
'Project: Reminder Popup Form
'Author : a.p.r. pillai
'Date   : March, 2024
'Rights : All Rights(c) Reserved by www.msaccesstips.com
'Remarks: Opens up preset Reminder Popup Form(s)
'       : on pre-scheuled Date/Month
'Example: Employees' Date-of-Birth Reminder.
'========================================================

Public Property Get m_Frm() As Access.Form
  Set m_Frm = frm
End Property

Public Property Set m_Frm(ByRef vfrm As Access.Form)
  Set frm = vfrm
End Property

Public Property Get m_cmd() As Access.CommandButton
  Set m_cmd = cmd
End Property

Public Property Set m_cmd(ByRef vcmd As Access.CommandButton)
  Set cmd = vcmd
End Property

Private Sub cmd_Click()
  Select Case cmd.Name
   Case "cmdPrint1"
        Call GreetingsPrint
        
    Case "cmdCancel1"
        DoCmd.Close acForm, "Reminder1"
    Case "cmdCancel2"
        DoCmd.Close acForm, "Reminder2"
    Case "cmdCancel3"
        DoCmd.Close acForm, "Reminder3"
  End Select
End Sub

Private Sub GreetingsPrint()
Dim strSQL As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim qryDef As DAO.QueryDef
Dim EID As Integer
Dim OutFile As String

'On Error GoTo GreetingsPrint_Err

Set db = CurrentDb
Set rst = db.OpenRecordset("RemindQ1_OnDate", dbOpenDynaset)

rst.MoveLast
rst.MoveFirst

Do While Not rst.EOF And Not rst.BOF
    EID = rst![EmployeeID]
    strSQL = "SELECT RemindQ1_OnDate.* FROM RemindQ1_OnDate "
    strSQL = strSQL & "WHERE (((RemindQ1_OnDate.EmployeeID)= "
    strSQL = strSQL & EID & "));"

Set qryDef = db.QueryDefs("BirthDayQ1OnDate_PDF")
    qryDef.SQL = strSQL
    db.QueryDefs.Refresh

DoCmd.OpenReport "Greetings1_PDF", acViewPreview
If MsgBox("Birthday Greetings Print Initiated, Proceed?", vbYesNo, "Greetings Print()") = vbNo Then
DoCmd.Close acReport, "Greetings1_PDF"
   Exit Sub
End If
DoCmd.Close acReport, "Greetings1_PDF"

OutFile = frm!Path & DLookup("Name", "BirthdayQ1OnDate_PDF", "EmployeeID = " & EID) & ".pdf"
DoCmd.OutputTo acOutputReport, "Greetings1_PDF", "PDFFormat(*.pdf)", OutFile, False, "", 0, acExportQualityPrint

rst.MoveNext
Loop

  rst.Close
  Set rst = Nothing
  Set db = Nothing


DoCmd.SetWarnings False
'Delete earlier saved records
DoCmd.OpenQuery "BirthDayReminder1_Del", acViewNormal

'Add latest records
DoCmd.OpenQuery "BDay_SavedQ1", acViewNormal

'Flag the Employee Record as Greetings Printed
'Reset the floags on January 1st, Next Year
DoCmd.OpenQuery "BirthDayQ_UpdateFlag1", acViewNormal
DoCmd.SetWarnings True

MsgBox "Greetings PDFs are saved in Path: " & frm!Path

GreetingsPrint_Exit:
Exit Sub

GreetingsPrint_Err:
MsgBox Err & ": " & Err.Description, , "GreetingsPrint_Click()"
Resume GreetingsPrint_Exit
End Sub

In the cmd_Click() Event Subroutine, the cmdPrint1 Command Button Click on the Reminder1 Form calls the GreetingsPrint() Subroutine, and prints the Birthday Greetings in PDF format. It updates the Employees1 Table, marking the BFlag logical Field as True to prevent it from appearing in the Employee record again in the Popup Form. The Greetings will be printed separately for each Employee Record.

After printing the Popup Form, the records will be saved into a separate temporary Table: Birthday_Reminder1.

The Sub_Init Interface Class Module VBA Code.

Option Compare Database
Option Explicit

Private cmd As Sub_CmdButton
Private frm As Form
Private Coll As New Collection

Public Property Get m_Frm() As Form
  Set m_Frm = frm
  
End Property

Public Property Set m_Frm(ByRef vfrm As Form)
  Set frm = vfrm
  
  Call Class_Init
  
End Property

Private Sub Class_Init()
Dim ctl As Control
Const EP = "[Event Procedure]"

'Set frm2 = frm.BReminderSub1.Form
For Each ctl In frm.Controls
    Select Case TypeName(ctl)
        Case "CommandButton"
          Select Case ctl.Name
            Case "cmdPrint1", "cmdCancel1", _
            "cmdCancel2", "cmdCancel3"
            Set cmd = New Sub_CmdButton
            Set cmd.m_Frm = frm
            Set cmd.m_cmd = ctl
                cmd.m_cmd.OnClick = EP
                Coll.Add cmd
            Set cmd = Nothing
        End Select
    End Select
Next
End Sub

Private Sub Class_Terminate()
Do While Coll.Count > 0
    Coll.Remove 1
Loop

End Sub

All three Popup Forms: Reminder1, Reminder2, and Reminder3 have Command Buttons with unique Names to Close the Forms, and all of them are included in the Class_Init() Subroutine. Because of their unique names, we could handle their Event Procedures in a Single Wrapper Class Module.

Even though the Code requirement is simple, the Standalone Class Module VBA Coding gives you much flexibility for maintaining Code in a centralized location. It needs only one Click Event Subroutine for several CommandButton Click Events.

Demo Database Download

RemnderPopup2.zip

Streamlining Code Database Compacting Utility

a.p.r. pillaiFebruary 29, 2024 No comments

Streamlining Form Module Code in Standalone Class Module.

The Database Compact/Repair Utility.

The 'Compact on Close' Option in Microsoft Access. When enabled under File --> Current Database --> Application Options, this feature automatically compacts the database when you open and close it. Additionally, you can manually select the Compact/Repair option from the File menu to Compact and repair the active database. If you need to compact an external file, you can select the "Compact and Repair" option from the Database Tools Menu.

If you prefer not to perform the Compact and Repair process daily, you can run the Compact/Repair Utility for multiple Databases together, such as weekly or biweekly. In this case, you can conveniently select those Databases from the Disk and add them to a ListBox, as illustrated in the form image below.

Right-click to open Large Image in New Tab/Window.

The ListBox is configured with the Multi-Select option, allowing you to choose multiple databases and run the Compact/Repair operation using the corresponding command button. Each selected database will be compacted individually, and its updated file size (in kilobytes) will be displayed in the second column of the ListBox. The FileBrowser Control.

The 'Add Databases' Command Button opens the File Browser Dialog Control, and you can select one or more Databases from your disk and add them to the ListBox.

Right-click to open a large image in New Tab/Window.

The Compact/Repair Function is Running.

The selected files from the Disk are added to the DirectoryList Table, the Source Table of the ListBox. As per your Compact/Repair schedule, you may open this Compact/Repair Utility, select the required files from the ListBox, then click on the 'Compact/Repair' Command Button.

Right-click to open Large Image in New Tab/Window.

Preparing for Compact/Repair.

In the Compact/Repair Utility Program, the Database is first backed up to a temporary location. The default Backup Path shown in the Text Box above the Command Buttons is D:\Tmp\. It is defined in the Default Value Property of the TextBox and used by the Compact/Repair Utility Program.

If you would like to take any Database Backup to a different location, change the Target path 'C:\Backup\' in the TextBox, before running the Compact/Repair option.

If you prefer a different location permanently, open the Form in Design View, display the TextBox Property Sheet, and set the Default Value Property to your preferred location, like D:\Backup\, and ensure that the last character in the path is a backslash.

Note: When the same database is compacted again, the old backup file will be replaced with the new one. Till that time, the Backup File will remain safe in that location.

The Compacting Procedure goes through the following steps:

The Source File is copied to the backup location to keep a copy of the Database safe before the Source file is compacted.
The 'DBEngine.CompactDatabase()' command is run to perform Compact and Repair operations on the database, and repairs the data if Database corruption is detected. In the event of data corruption, there is a risk of data loss, and the specific information regarding the errors encountered is preserved in the System Table MSysCompactErrors. To mitigate such situations, it is advisable to restore the data from previously created database backups, if available.
All objects from the source database, including both user-created and system objects, are transferred into a new database. The new temporary database is "db1.accdb" (or "db1.mdb" depending on the file format) and is located in the designated backup path: D:\tmp\db1.accdb. The replication process excludes the system's temporary work files, ensuring a comprehensive transfer of objects while omitting non-essential temporary data.
Deletes the Source File from its home location.
The Compacted D:\tmp\db1.accdb file is transferred to the home location with its original Database name.

Note: The Access System goes through the same procedure when you run the Compacting operation directly from the Access System, except for the Database Backup procedure.

Streamlined VBA Coding in Standalone Class Module.

Having gained insights into the utility highlighted in the previous introduction, it is now opportune to explore the streamlined event subroutine coding procedure implemented in this specific project. The necessary VBA code for event subroutines is meticulously designed in a standalone class module, enhancing code maintenance and debugging. This organized code structure within the standalone Class Module facilitates easy transportation to other projects, safeguarding valuable work from being entangled with less critical code in form modules. By adopting this streamlined coding approach, the practice of reusing identical code segments across controls of the same type within the form is encouraged, eliminating duplicative coding efforts.

The Command Button Wrapper Class.

There is a single Wrapper Class dedicated to the Command Button controls, along with a separate Interface (Intermediary) Class Module. The Interface Class is responsible for creating and managing instances of the Command Button Wrapper Class while facilitating Click Event handling. A `Collection` object is used to store and manage all Command Button Wrapper Class instances, enabling the monitoring and capture of Command Button Click events generated within the Compact/Repair form.

The Command Button Wrapper Class VBA Code.

Option Compare Database
Option Explicit

Private cmdfrm As Form
Private WithEvents cmd As CommandButton

Private strPath As String
Private bkupPath As String
Dim lst As ListBox
Dim lstcount As Integer
Dim xtn As String

'------------------------------------------------------
'Streamlining Form Module Code
'in Stand-alone Class Modules
'------------------------------------------------------
'Database Compact/Repair Utility
'Author: a.p.r. pillai
'Date  : 20/02/2024
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

'Form's Property GET/SET Procedures
Public Property Get cmd_Frm() As Form
    Set cmd_Frm = cmdfrm
End Property

Public Property Set cmd_Frm(ByRef cfrm As Form)
    Set cmdfrm = cfrm
End Property

'Command Button Property GET/SET Procedures
Public Property Get c_cmd() As CommandButton
    Set c_cmd = cmd
End Property

Public Property Set c_cmd(ByRef pcmd As CommandButton)
    Set cmd = pcmd
    
    Call DefaultPath
    
End Property

'The Click Event Subroutines
Private Sub cmd_Click()
On Error GoTo cmd_Click_Err
Select Case cmd.Name
  Case "cmdQuit"
    If MsgBox("Close Compact_Repair Form?", vbOKCancel + vbQuestion, "cmd_Click") = vbOK Then
        DoCmd.Close acForm, cmdfrm.Name
        Exit Sub
    End If

    Case "cmdFileDialog"
        Call FileDialog 'Display selected Path & files
        cmdfrm.dbList.Requery
        
    Case "cmdCompact"
        Call DBPrepare
        
    Case "cmdDelete"
        Call DBDelete
        
End Select

cmd_Click_Exit:
Exit Sub

cmd_Click_Err:
MsgBox Err & " : " & Err.Description, , "cmd_Click()"
Resume cmd_Click_Exit
End Sub

Private Sub DBDelete()
'Delete the selected Items from the DirectoryList Table
Dim delCount As Integer
Dim j As Integer
Dim k As Integer
Dim DB As Database
Dim dbName As String
Dim msg As String
Dim Rst As Recordset
Dim opt As Integer

On Error GoTo DBDelete_Err
opt = 0

msg = "1. Delete Selected." & vbCr & vbCr _
& "2. Delete All from List." & vbCr & vbCr _
& "3. Cancel Deletion."
While opt < 1 Or opt > 3
    opt = InputBox(msg, "Select Option.", 3)
Wend
Select Case opt
    Case 1
        GoTo Selected
    Case 2
      msg = "Empty the Database List...?"
      If MsgBox(msg, vbYesNo + vbCritical, "DeleteList()") = vbNo Then
        Exit Sub
      Else
        DoCmd.SetWarnings False
        DoCmd.OpenQuery "DeleteAll_ListQ"
        DoCmd.SetWarnings True
        cmdfrm.dbList.Requery
        cmdfrm.cmdDelete.eabled = False
        Exit Sub
      End If
    Case 3
        Exit Sub
End Select

Selected:
delCount = CheckList()
If delCount > 0 Then
    msg = "Delete " & delCount & " Items." & vbCr & vbCr & "Proceed...?"
    If MsgBox(msg, vbYesNo, "DBDelete()") = vbNo Then
        Exit Sub
    End If
    
    Set DB = CurrentDb
    Set Rst = DB.OpenRecordset("DirectoryList", dbOpenDynaset)
    Set lst = cmdfrm.dbList
    
For j = 0 To lstcount
    If lst.Selected(j) Then
      dbName = lst.Column(0, j)
      Rst.FindFirst "Path = '" & dbName & "'"
      If Not Rst.NoMatch Then
        Rst.Delete
        Rst.Requery
      End If
    End If
Next
Rst.Close
Set Rst = Nothing
Set DB = Nothing

lst.Requery
    MsgBox delCount & " Item(s) Deleted From List.", , "DBDelete()"
Else
    MsgBox delCount & " Item(s) Selected for Deletion!", , "DBDelete()"
End If

DBDelete_Exit:
Exit Sub

DBDelete_Err:
MsgBox Err & " : " & Err.Description, , "DBDelete()"
Resume DBDelete_Exit
End Sub

Private Sub DBPrepare()
'Preparatory Procedure for Compacting
'the selected Databases individually
Dim xselcount As Integer
Dim dbName As String
Dim ldbName As String
Dim strTmp As String
Dim i As Integer
Dim j As Integer
Dim timr As Double
Dim fs, f
Dim lockfile As String
Dim msg As String

bkupPath = cmdfrm!BackupPath
'create a Backup Folder
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(bkupPath)
    If Err = 76 Or Err > 0 Then
       Err.Clear
       fs.createfolder (bkupPath)
    End If

On Error GoTo DBPrepare_Err

'Remove existing workfiles from backup location
xselcount = CheckList()
If xselcount = 0 Then
msg = "Select Database(s) from List for Compacting!"
MsgBox msg, , "DBPrepare()"
    Exit Sub
End If

'Ensure selected database is not active
msg = "Ensure that Selected Databases are not in Use. " _
& vbCrLf & "Proceed...?"

If MsgBox(msg, vbYesNo + vbDefaultButton2 + vbQuestion, _
"DBPrepare()") = vbNo Then
   Exit Sub
End If

'Check the selected database is active or not
'if inactive then submit it to DBCompact() Program.
For j = 0 To lstcount
    If lst.Selected(j) Then
       dbName = Trim(lst.Column(0, j))
       i = InStrRev(dbName, ".")
       xtn = Mid(dbName, i) 'extract extension
       lockfile = IIf(xtn = ".mdb", "ldb", "laccdb")
       ldbName = Left(dbName, i)
       ldbName = ldbName & lockfile 'for checking the presense of lock file.
       If Len(Dir(ldbName)) > 0 Then 'database is active
          MsgBox "Database: " & dbName & vbCrLf & "is active. Skipping to the Next in list."
          GoTo nextstep
       End If

    'Prepare for Compacting and to display the status messages.
       msg = "Compact/Repair: " & dbName & vbCrLf & "Proceed...?"
       If MsgBox(msg, vbQuestion + vbDefaultButton2 + vbYesNo, "DBPrepare()") = vbYes Then
            cmdfrm.lblNote.Visible = False
            cmdfrm.lblStat.Caption = "Working, Please wait..."
            DoEvents

    Call DBCompact(dbName) 'Run Compacting

            cmdfrm.lblStat.Caption = ""
            DoEvents

nextstep:
            Sleep 5
        End If
    End If
Next

msg = "Selected Database(s) Compacted Successfully."
MsgBox msg, , "DBPrepare()"

    Sleep 3

cmdfrm.lblNote.Visible = True
cmdfrm.lblStat.Caption = ""


strTmp = bkupPath & "db1" & xtn 'Delete the temporary file
Call KillTempFile(strTmp)

Set fs = Nothing
Set f = Nothing
Set lst = Nothing

DBPrepare_Exit:
Exit Sub

DBPrepare_Err:
MsgBox Err.Description, , "DBPrepare()"
Resume DBPrepare_Exit
End Sub

Private Sub DBCompact(ByVal strdb As String)
'Compact/Repair Database received as Parameter
Dim t As Long
Dim xdir As String
Dim strbk As String
Dim strTmp As String
Dim tmp As String
Dim chkFile As String
Dim msg As String

On Error GoTo dbCompact_Err

tmp = cmdfrm!BackupPath

strTmp = tmp & "db1" & xtn

chkFile = strTmp
Call KillTempFile(chkFile)

t = InStrRev(strdb, "\")
If t > 0 Then
   strbk = Mid(strdb, t + 1)
End If
strbk = tmp & strbk

chkFile = strbk
Call KillTempFile(chkFile)

'Make a Copy in d:\tmp folder for safe keep
msg = "Taking Backup of " & strdb & vbCrLf _
& "to " & tmp
cmdfrm.lblMsg.Caption = msg
DoEvents

'Take a Backup of Original File to the Backup Location
   FileCopy strdb, strbk

msg = "Transferring Objects from " & strdb & vbCrLf _
& "to " & tmp & "db1" & xtn
cmdfrm.lblMsg.Caption = msg
DoEvents

'https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/dbengine-compactdatabase-method-dao
'Compact Database to D:\tmp\db1.accdb
   DBEngine.CompactDatabase strdb, strTmp
   
' Delete uncompacted Database and Copy Compacted db1.mdb with
' the Original Name
msg = "Creating " & strdb & " from " & tmp & "db1" & xtn
cmdfrm.lblMsg.Caption = msg
DoEvents

'Delete uncompacted file
chkFile = strdb
Call KillTempFile(chkFile)

'Create Compacted File with its original name in its home location
    DBEngine.CompactDatabase strTmp, strdb

msg = strdb & " Compacted/Repaired Successfully."

cmdfrm.lblMsg.Caption = msg
DoEvents

Call dbListUpdate(strdb) 'Update the DirectoryList Table

dbCompact_Exit:
Exit Sub

dbCompact_Err:
MsgBox Err & " : " & Err.Description, , "dbCompact()"
Resume dbCompact_Exit
End Sub

Private Function CheckList() As Integer
'Take selected items Count
Dim k As Integer
Dim xcount As Integer

On Error GoTo CheckList_Err

Set lst = cmdfrm.dbList
lstcount = DCount("*", "DirectoryList")

xcount = 0
For k = 0 To lstcount
If lst.Selected(k) Then
    xcount = xcount + 1
End If
Next

If xcount = 0 Then
   MsgBox "No Database(s)Selected."
   Exit Function
End If

CheckList = xcount

CheckList_Exit:
Exit Function

CheckList_Err:
MsgBox Err & ": " & Err.Description, , "CheckList()"
Resume CheckList_Exit
End Function

Private Sub dbListUpdate(ByVal cmpPath As String)
'Update the File Size of the Database after Compacting
On Error GoTo dbListUpdate_Err
Dim sPath As String
Dim i As Variant
Dim DB As Database
Dim Rst As Recordset
Set DB = CurrentDb
Set Rst = DB.OpenRecordset("DirectoryList", dbOpenDynaset)

Rst.MoveFirst
Rst.FindFirst "Path = '" & cmpPath & "'"
If Not Rst.NoMatch Then
    sPath = Rst!Path
    Rst.Edit
    Rst!FileLengthKB = FileLen(sPath) / 1024 'Db size after compacting
    Rst.Update
End If

Rst.Close
cmdfrm.dbList.Requery

dbListUpdate_Exit:
Set Rst = Nothing
Set DB = Nothing
Exit Sub

dbListUpdate_Err:
MsgBox Err & ": " & Err.Description, , "dbListUpdate()"
Resume dbListUpdate_Exit
End Sub

Private Sub DefaultPath()
Dim strLoc As String
'Default path for CommonDialog Control
   strLoc = CurrentProject.Path & "\*.accdb"
   strPath = strLoc 'Assign to Global Variable strPath
   
End Sub

Private Sub FileDialog()
On Error GoTo cmdFileDialog_Err

'Requires reference to Microsoft Office 12.0 Object Library.
Dim fDialog As Office.FileDialog
Dim DB As DAO.Database
Dim Rst As DAO.Recordset
Dim defPath As String
Dim varFile As Variant
Dim strfiles As String

   'Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
   With fDialog
      'Allow user to make multiple selections of disk files.
      .AllowMultiSelect = True
      .InitialFileName = Dir(strPath)
      .InitialView = msoFileDialogViewDetails
      'Set the title of the dialog box.
      .Title = "Please select one or more files"

      'Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "Access Databases", "*.mdb; *.accdb"
      .Filters.Add "Access Projects", "*.adp"
      .Filters.Add "All Files", "*.*"
      .FilterIndex = 1
      '.Execute
      'Show the dialog box. If the .Show method returns True, the
      'user picked at least one file. If the .Show method returns
      'False, the user clicked Cancel.
    If .Show = True Then
        Set DB = CurrentDb
        Set Rst = DB.OpenRecordset("DirectoryList", dbOpenDynaset)
        'Add all selected files to the DirectoryList Table
        defPath = ""
      For Each varFile In .SelectedItems
         If defPath = "" Then
            defPath = Left(varFile, InStrRev(varFile, "\"))
            defPath = defPath & "*.*"
            strPath = defPath
         End If
            Rst.AddNew
            Rst![Path] = varFile
            Rst![FileLengthKB] = FileLen(varFile) / 1024
            Rst.Update
      Next
            cmdfrm.cmdDelete.Enabled = True
        Else
            MsgBox "You clicked Cancel in the file dialog box."
        End If
      
   End With

cmdFileDialog_Exit:
Exit Sub

cmdFileDialog_Err:
MsgBox Err & " : " & Err.Description, , "cmdFileDialog_Click()"
Resume cmdFileDialog_Exit
End Sub

Private Sub KillTempFile(ByVal filename As String)
On Error GoTo KillTempFile_Err
'Manage Temporary Files
    If Len(Dir(filename)) > 0 Then
        Kill filename
    End If

KillTempFile_Exit:
Exit Sub

KillTempFile_Err:
MsgBox Err & ": " & Err.Description, , "KillTempFile()"
Resume KillTempFile_Exit
End Sub

The Command Button Wrapper Class starts with the main Properties, the Form Object, and Command Button Control declarations. The CommandButton Control is declared and qualified with the Keyword WithEvents for Click Event Capturing when fired from the Form.

A few local Variables are also declared in the global area of the Class Module, followed by the Form and Command Button Get and Set Property Procedures.

Despite four Command Buttons on the Form, a single Click Event Subroutine within the Command Button Wrapper Class suffices. This streamlined approach captures all four Command Button Clicks in the same Event Subroutine, allowing the execution of their respective Event Procedures. This efficiency is achievable through the implementation of streamlined Event Procedure coding.

When examining the Event Subroutine Code in order of priority, the first step is adding the databases slated for the Compact/Repair procedure to the ListBox. This is accomplished through the Click Event of the Command Button labeled 'Add Databases,' with the name 'CmdFileDialog.' The Click Event, in turn, invokes the FileDialog() Subroutine. The Code Segment is given below:

Private Sub FileDialog()
On Error GoTo cmdFileDialog_Err

'Requires reference to Microsoft Office 12.0 Object Library.
Dim fDialog As Office.FileDialog
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim defPath As String
Dim varFile As Variant
Dim strfiles As String

   'Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
   With fDialog
      'Allow user to make multiple selections of disk files.
      .AllowMultiSelect = True
      .InitialFileName = Dir(strPath)
      .InitialView = msoFileDialogViewDetails
      'Set the title of the dialog box.
      .Title = "Please select one or more files"

      'Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "Access Databases", "*.mdb; *.accdb"
      .Filters.Add "Access Projects", "*.adp"
      .Filters.Add "All Files", "*.*"
      .FilterIndex = 1
      '.Execute
      'Show the dialog box. If the .Show method returns True, the
      'user picked at least one file. If the .Show method returns
      'False, the user clicked Cancel.
    If .Show = True Then
        Set db = CurrentDb
        Set rst = db.OpenRecordset("DirectoryList", dbOpenDynaset)
        'Add all selected files to the DirectoryList Table
        defPath = ""
      For Each varFile In .SelectedItems
         If defPath = "" Then
            defPath = Left(varFile, InStrRev(varFile, "\"))
            defPath = defPath & "*.*"
            strPath = defPath
         End If
            rst.AddNew
            rst![Path] = varFile
            rst![FileLengthKB] = FileLen(varFile) / 1024
            rst.Update
      Next
            cmdfrm.cmdDelete.Enabled = True
        Else
            MsgBox "You clicked Cancel in the file dialog box."
        End If
      
   End With

cmdFileDialog_Exit:
Exit Sub

cmdFileDialog_Err:
MsgBox Err & " : " & Err.Description, , "cmdFileDialog_Click()"
Resume cmdFileDialog_Exit
End Sub

This is the same Office.FileDialog Control (the File Browser Control) and the Program we used in the earlier Episode with the title External Files' List in Hyperlinks published earlier. If you click this link, you will be directed to the specific part of the Page that gives the function details.

In this scenario, utilise the DirectoryList Table to store the databases selected from the disk, which subsequently populate the ListBox on the Form. The table encompasses two fields: Path and FileLengthKB. The former accommodates the full Pathname of the database, while the latter calculates the file size in kilobytes when added to the table. Following the Compact/Repair operations, this table updates to reflect the altered file sizes.

Users can select one or more databases from the list and initiate the Compact/Repair process by clicking on the designated Command Button. This action triggers execution of the DBPrepare() Subroutine, which in turn identifies the selected database(s) in the ListBox and passes them to the DBCompact() Subroutine for the Compact/Repair operation.

The DBPrepare() Subroutine VBA Code.

Private Sub DBPrepare()
'Preparatory Procedure for Compacting
'the selected Databases individually
Dim xselcount As Integer
Dim dbName As String
Dim ldbName As String
Dim strTmp As String
Dim i As Integer
Dim j As Integer
Dim timr As Double
Dim fs, f
Dim lockfile As String
Dim msg As String

bkupPath = cmdfrm!BackupPath
'create a Backup Folder
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(bkupPath)
    If Err = 76 Or Err > 0 Then
       Err.Clear
       fs.createfolder (bkupPath)
    End If

On Error GoTo DBPrepare_Err

'Remove existing workfiles from backup location
xselcount = CheckList()
If xselcount = 0 Then
msg = "Select Database(s) from List for Compacting!"
MsgBox msg, , "DBPrepare()"
    Exit Sub
End If

'Ensure selected database is not active
msg = "Ensure that Selected Databases are not in Use. " _
& vbCrLf & "Proceed...?"

If MsgBox(msg, vbYesNo + vbDefaultButton2 + vbQuestion, _
"DBPrepare()") = vbNo Then
   Exit Sub
End If

'Check the selected database is active or not
'if inactive then submit it to DBCompact() Program.
For j = 0 To lstcount
    If lst.Selected(j) Then
       dbName = Trim(lst.Column(0, j))
       i = InStrRev(dbName, ".")
       xtn = Mid(dbName, i) 'extract extension
       lockfile = IIf(xtn = ".mdb", "ldb", "laccdb")
       ldbName = Left(dbName, i)
       ldbName = ldbName & lockfile 'for checking the presense of lock file.
       If Len(Dir(ldbName)) > 0 Then 'database is active
          MsgBox "Database: " & dbName & vbCrLf & "is active. Skipping to the Next in list."
          GoTo nextstep
       End If

    'Prepare for Compacting and to display the status messages.
       msg = "Compact/Repair: " & dbName & vbCrLf & "Proceed...?"
       If MsgBox(msg, vbQuestion + vbDefaultButton2 + vbYesNo, "DBPrepare()") = vbYes Then
            cmdfrm.lblNote.Visible = False
            cmdfrm.lblStat.Caption = "Working, Please wait..."
            DoEvents

    Call DBCompact(dbName) 'Run Compacting

            cmdfrm.lblStat.Caption = ""
            DoEvents

nextstep:
            Sleep 5
        End If
    End If
Next

msg = "Selected Database(s) Compacted Successfully."
MsgBox msg, , "DBPrepare()"

    Sleep 3

cmdfrm.lblNote.Visible = True
cmdfrm.lblStat.Caption = ""


strTmp = bkupPath & "db1" & xtn 'Delete the temporary file
Call KillTempFile(strTmp)

Set fs = Nothing
Set f = Nothing
Set lst = Nothing

DBPrepare_Exit:
Exit Sub

DBPrepare_Err:
MsgBox Err.Description, , "DBPrepare()"
Resume DBPrepare_Exit
End Sub

The above DBPrepare() Subroutine selects the User-selected Databases individually, passes them to the actual Compacting Subroutine DBCompact() for Compact/Repair operations, and restores the Database to its home location.

The DBCompact Subroutine VBA Code.

Private Sub DBCompact(ByVal strdb As String)

'Compact/Repair Database received as Parameter
Dim t As Long
Dim xdir As String
Dim strbk As String
Dim strTmp As String
Dim tmp As String
Dim chkFile As String
Dim msg As String

On Error GoTo dbCompact_Err

tmp = cmdfrm!BackupPath

strTmp = tmp & "db1" & xtn

chkFile = strTmp
Call KillTempFile(chkFile)

t = InStrRev(strdb, "\")
If t > 0 Then
   strbk = Mid(strdb, t + 1)
End If
strbk = tmp & strbk

chkFile = strbk
Call KillTempFile(chkFile)

'Make a Copy in d:\tmp folder for safe keep
msg = "Taking Backup of " & strdb & vbCrLf _
& "to " & tmp
cmdfrm.lblMsg.Caption = msg
DoEvents

'Take a Backup of Original File to the Backup Location
   FileCopy strdb, strbk

msg = "Transferring Objects from " & strdb & vbCrLf _
& "to " & tmp & "db1" & xtn
cmdfrm.lblMsg.Caption = msg
DoEvents

'https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/dbengine-compactdatabase-method-dao
'Compact Database to D:\tmp\db1.accdb
   DBEngine.CompactDatabase strdb, strTmp
   
' Delete uncompacted Database and Copy Compacted db1.mdb with
' the Original Name
msg = "Creating " & strdb & " from " & tmp & "db1" & xtn
cmdfrm.lblMsg.Caption = msg
DoEvents

'Delete uncompacted file
chkFile = strdb
Call KillTempFile(chkFile)

'Create Compacted File with its original name in its home location
    DBEngine.CompactDatabase strTmp, strdb

msg = strdb & " Compacted/Repaired Successfully."

cmdfrm.lblMsg.Caption = msg
DoEvents

Call dbListUpdate(strdb) 'Update the DirectoryList Table

dbCompact_Exit:
Exit Sub

dbCompact_Err:
MsgBox Err & " : " & Err.Description, , "dbCompact()"
Resume dbCompact_Exit
End Sub

There are three other small supporting Subroutines called from both the DBPrepare() and DBCompact() Subroutines.

The CheckList() Subroutine.

Private Function CheckList() As Integer
'Take selected items Count
Dim k As Integer
Dim xcount As Integer

On Error GoTo CheckList_Err

Set lst = cmdfrm.dbList
lstcount = DCount("*", "DirectoryList")

xcount = 0
For k = 0 To lstcount
If lst.Selected(k) Then
    xcount = xcount + 1
End If
Next

If xcount = 0 Then
   MsgBox "No Database(s)Selected."
   Exit Function
End If

CheckList = xcount

CheckList_Exit:
Exit Function

CheckList_Err:
MsgBox Err & ": " & Err.Description, , "CheckList()"
Resume CheckList_Exit
End Function

The above Subroutine checks whether any Item is selected in the ListBox and takes its count when the 'Compact/Repair' or 'Delete from List' Command Button is clicked. If selected, then the selected operation is performed.

The dbListUpdate() Subroutine in VBA.

Private Sub dbListUpdate(ByVal cmpPath As String)
'Update the File Size of the Database after Compacting
On Error GoTo dbListUpdate_Err
Dim sPath As String
Dim i As Variant
Dim DB As Database
Dim Rst As Recordset
Set DB = CurrentDb
Set Rst = DB.OpenRecordset("DirectoryList", dbOpenDynaset)

Rst.MoveFirst
Rst.FindFirst "Path = '" & cmpPath & "'"
If Not Rst.NoMatch Then
    sPath = Rst!Path
    Rst.Edit
    Rst!FileLengthKB = FileLen(sPath) / 1024 'Db size after compacting
    Rst.Update
End If

Rst.Close
cmdfrm.dbList.Requery

dbListUpdate_Exit:
Set Rst = Nothing
Set DB = Nothing
Exit Sub

dbListUpdate_Err:
MsgBox Err & ": " & Err.Description, , "dbListUpdate()"
Resume dbListUpdate_Exit
End Sub

This Program is called from the DBCompact() Subroutine to update the File Size in Kilobytes in the list box after compacting the Database.

The DBDelete() Subroutine.

Private Sub DBDelete()
'Delete the selected Items from the DirectoryList Table
Dim delCount As Integer
Dim j As Integer
Dim k As Integer
Dim DB As Database
Dim dbName As String
Dim msg As String
Dim Rst As Recordset
Dim opt As Integer

On Error GoTo DBDelete_Err
opt = 0

msg = "1. Delete Selected." & vbCr & vbCr _
& "2. Delete All from List." & vbCr & vbCr _
& "3. Cancel Deletion."
While opt < 1 Or opt > 3
    opt = InputBox(msg, "Select Option.", 3)
Wend
Select Case opt
    Case 1
        GoTo Selected
    Case 2
      msg = "Empty the Database List...?"
      If MsgBox(msg, vbYesNo + vbCritical, "DeleteList()") = vbNo Then
        Exit Sub
      Else
        DoCmd.SetWarnings False
        DoCmd.OpenQuery "DeleteAll_ListQ"
        DoCmd.SetWarnings True
        cmdfrm.dbList.Requery
        cmdfrm.cmdDelete.eabled = False
        Exit Sub
      End If
    Case 3
        Exit Sub
End Select

Selected:
delCount = CheckList()
If delCount > 0 Then
    msg = "Delete " & delCount & " Items." & vbCr & vbCr & "Proceed...?"
    If MsgBox(msg, vbYesNo, "DBDelete()") = vbNo Then
        Exit Sub
    End If
    
    Set DB = CurrentDb
    Set Rst = DB.OpenRecordset("DirectoryList", dbOpenDynaset)
    Set lst = cmdfrm.dbList
    
For j = 0 To lstcount
    If lst.Selected(j) Then
      dbName = lst.Column(0, j)
      Rst.FindFirst "Path = '" & dbName & "'"
      If Not Rst.NoMatch Then
        Rst.Delete
        Rst.Requery
      End If
    End If
Next
Rst.Close
Set Rst = Nothing
Set DB = Nothing

lst.Requery
    MsgBox delCount & " Item(s) Deleted From List.", , "DBDelete()"
Else
    MsgBox delCount & " Item(s) Selected for Deletion!", , "DBDelete()"
End If

DBDelete_Exit:
Exit Sub

DBDelete_Err:
MsgBox Err & " : " & Err.Description, , "DBDelete()"
Resume DBDelete_Exit
End Sub

To remove some databases from the ListBox, you must select them from the ListBox and click the 'Delete from List' Command Button. The DBDelete() Subroutine is called; the selected items will be deleted from the DirectoryList table, and the ListBox updated to reflect the change.

The KillTempFile() Subroutine.

Private Sub KillTempFile(ByVal filename As String)
On Error GoTo KillTempFile_Err
'Manage Temporary Files
    If Len(Dir(filename)) > 0 Then
        Kill filename
    End If

KillTempFile_Exit:
Exit Sub

KillTempFile_Err:
MsgBox Err & ": " & Err.Description, , "KillTempFile()"
Resume KillTempFile_Exit
End Sub

The Compact/Repair Program creates Temporary Databases for System use and deletes them using the above Subroutine. This Subroutine is called from within the DBPrepare() and DBCompact() Subroutines.

The FLst_ObjInit Interface Class Module VBA Code.

Option Compare Database
Option Explicit

Private cmd As FLst_CmdButton
Private frm As Access.Form
Private Coll As New Collection

'------------------------------------------------------
'Streamlining Form Module Code
'in Stand-alone Class Modules
'------------------------------------------------------
'Database Compact/Repair Utility
'Author: a.p.r. pillai
'Date  : 20/02/2024
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

Public Property Get Ini_Frm() As Access.Form
    Set Ini_Frm = frm.m_cFrm
End Property

Public Property Set Ini_Frm(ByRef pFrm As Access.Form)
    Set frm = pFrm
    
    Call Class_Init
End Property

Private Sub Class_Init()
On Error GoTo Class_Init_Err
Dim ctl As Control
Dim listcount As Long
Const EP = "[Event Procedure]"

listcount = DCount("*", "DirectoryList")

'If ListBox is empty then disable
'cmdDelete Command Button
If listcount = 0 Then
    frm.cmdDelete.Enabled = False
Else
    frm.cmdDelete.Enabled = True
End If

For Each ctl In frm.Controls
Select Case TypeName(ctl)
      Case "CommandButton"
        Select Case ctl.Name
            Case "cmdFileDialog", "cmdCompact", _
            "cmdDelete", "cmdQuit"
            
                Set cmd = New FLst_CmdButton
                Set cmd.cmd_Frm = frm
                Set cmd.c_cmd = ctl
        
                    cmd.c_cmd.OnClick = EP
                Coll.Add cmd
                Set cmd = Nothing
        End Select
End Select
Next

Class_Init_Exit:
Exit Sub

Class_Init_Err:
MsgBox Err & " : " & Err.Description, , "Class_Init()"
Resume Class_Init_Exit
End Sub

Private Sub Class_Terminate()
Do While Coll.Count > 0
    Coll.Remove 1
Loop
End Sub

Within the global declaration area, the FLst_CmdButton Class, the Form Object frm, and the Collection Object Coll are declared. This is succeeded by the inclusion of Get/Set Property Procedures for the frm property. In adherence to common practice, the active Form Object is passed from the Form_Load() Event Procedure to the pFrm parameter. Subsequently, it is assigned to the Form Object frm in the FLst_ObjInit Class Module.

Upon obtaining a reference to the active Form object within the Interface Class and assigning it to the frm Object through the Set Property Procedure, the Class_Init() Subroutine is initiated.

Within the Class_Init() Subroutine, a constant named "EP" is created to represent the [Event Procedure] text. Following this, a check is implemented to determine the status of the DirectoryList Table, which serves as the source data for the ListBox. If the DirectoryList table is empty, the [Delete from List] Command Button on the Form is disabled.

Within the subsequent For...Next Loop, the program iterates through the Command Buttons on the Form. When a Command Button is identified, an individual instance of the Command Button Wrapper Class is instantiated. This instance is then assigned the respective Control Reference, and the necessary Events, specifically the Click Events in this case, are enabled. These instances are subsequently stored in the Collection Object to retain them in memory.

You may take note of the following Statements:

                Set cmd = New FLst_CmdButton
                Set cmd.cmd_Frm = frm
                Set cmd.c_cmd = ctl
        
                    cmd.c_cmd.OnClick = EP
                Coll.Add cmd
                Set cmd = Nothing

The first statement creates an instance of the FLst_CmdButton Class in memory. Its cmd_frm Property is then configured with the active form object frm, and the current Command Button control Reference in ctl is transmitted to the c_cmd Property. When these two properties are armed with the references of the Form and Command Button, the resulting instance of the Command Button Wrapper Class effectively mirrors the properties and characteristics of the corresponding Command Button on the Form.

The subsequent statement, cmd.c_cmd.OnClick = EP is functionally equivalent to specifying the text [Event Procedure] of the Command Button in the OnClick Event Property. Following the activation of the Event Procedure, the current instance of the Wrapper Class is added to the Collection Object in memory. This enables the CommandButton Event capturing and subsequently executes the associated Event Procedure in the Wrapper Class Module.

You should not ignore the next statement: Set cmd = Nothing.

At this point, you may be in doubt. When we execute the above statement, it will erase the Wrapper Class Instance we created in memory.

While the resemblance may be apparent, there is a crucial distinction. The inclusion of this instance of the Wrapper Class Object in the Collection Object ensures that the Collection Object remains active, retaining the Wrapper Class Instance in memory until the Form is closed and subsequently cleared.
The reason we need to execute Set cmd = Nothing is to avoid creating the CmdButton Wrapper Class Instance for another Command Button on the Form without clearing the previous one from memory. Without this step, attempts to create a second instance of the Command Button Wrapper Class could overwrite the earlier instance in the same memory location. Thus, resetting the cmd ensures that a new instance can be created without interference with the earlier Instance of the Wrapper Class.
If we don't execute the Set cmd = Nothing, then only the last Command Button's Event will remain valid, and others will keep overwriting the earlier Instances.
After the cmd object is reset, creating another Command Button Wrapper Class instance searches for an available memory area to create a new instance. This ensures the proper allocation of memory for the new instance, preventing any interference with existing instances.
So, please don't ignore this statement. Since it is a logical issue, you may need help finding it so easily when debugging.

The Compact_Repair Form Module VBA Code.

Option Compare Database
Option Explicit

Dim Obj As New FLst_ObjInit

Private Sub Form_Load()
DoCmd.Restore
Set Obj.Ini_Frm = Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set Obj = Nothing
End Sub

As customary, we have instantiated the Interface Class FLst_ObjInit in the global declaration section of the Form's Class Module. This declaration ensures that all three sets of Class Modules—Wrapper Class, Interface Class, and Form Class Module—are loaded into memory.

In the Form_Load() event procedure, the 'obj.Ini_Frm' property of the Interface Class is assigned the reference to the active Form object, denoted by Me. This initiates a series of actions, and within moments, the system is primed to handle programmed events and their respective functions.

I hope this utility Program proves to be a valuable tool for optimizing your Access applications over an extended period, and the best part is that it comes at no cost.