October 2023 ~ LEARN MS-ACCESS TIPS AND TRICKS

Streamlining Form VBA External Files List HyperLinks

a.p.r. pillaiOctober 30, 2023 No comments

External Files List in Hyperlinks in Form.

The Office.FileDialog Control

The FileDialog Control displays files from the selected folder as hyperlinks in the form. Clicking on a hyperlink will open the file in its native application, if available.

The File Dialog control features user-defined filters that allow users to display specific categories of files, such as Word Documents, Excel Worksheet files, and Access Databases, or view all files within a folder. Select the required files and click on the 'Create File Link' Command Button to add the selected files to a table and display them in the form in Datasheet View as hyperlinks. The full file pathnames are shown in the second column for reference.

Files' List Display Image.

After setting the File Filter in the TextBox with the name Pathname, Click on the Create File Links Command Button to open the following File Browser control to display the Files and Folders.

At this point, you can select any folder to search for files if needed. To select several adjoining files, click on the first file, hold the Shift key, click on the last file, and then click the 'Open' command button. The selected files will appear in the list, as shown in the first image.

The Form Module VBA Code.

Option Compare Database
Option Explicit

Private FD As New FLst_Object_Init

Private Sub Form_Load()
    Set FD.fl_Frm = Me
End Sub

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

In the Global Declaration area, the Class_Init Class Module with the name FLst_Object_Init Object is declared with the name FD. An Instance of the Object is created in memory using the keyword New in the declaration.

In the Form_Load() Event Procedure the current Form Object is passed to the FD.fl_Frm Property to the FD Object Instance.

The FLst_Object_Init Class Module Code.

The FLst_Object_Init with the Class_Init() Subroutine VBA Code is given below:

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
'------------------------------------------------------
'Disk Directory Listing in Hyperlinks
'Author: a.p.r. pillai
'Date  : 25/10/2023
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

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

Public Property Set fl_Frm(ByRef pNewValue As Access.Form)
    Set frm = pNewValue
    
    Call Class_Init
End Property

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

'=============================
'Calling the Public Function ButtonStatus() From FLst_CmdButton Class
'from the Flst_CmdButton Class directly,
Set cmd = New FLst_CmdButton 'Create a separate instance
Set cmd.cmd_Frm = frm 'Pass the Form Object to the Property

Call cmd.ButtonStatus 'Call the Public Function, with Param, if any
Set cmd = Nothing 'Remove the instance
'=============================

For Each ctl In frm.Controls
Select Case TypeName(ctl)
      Case "CommandButton"
        Select Case ctl.Name
            Case "cmdHelp", "cmdFileDialog", _
            "cmdDelLink", "cmdDelFile", _
            "cmdClose", "cmdDelAll"
            
                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

End Sub

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

The following two Subroutines, if present in the Class Module, run automatically.

Class_Initialize()
Class_Terminate()

Assume that we have both the above Subroutines in ClassA.

You create an Instance of ClassA in ClassB, like Dim A As ClassA, Set A = New ClassA. The Class_Initialize() Subroutine in ClassA runs, if present. You can put any initializing steps of Code within this Subroutine.

When you execute the Statement: Set A = Nothing or ClassB object Unloads the Class_Terminate() Subroutine in ClassA executes. You can do the clean-up work, like Set Obj = Nothing, in this Subroutine to clear memory for other use.

This is useful when other objects like Collection Object, Dictionary Object, or other Class Module declarations are present in the Class Module. The following Class1 Module is Instantiated in the Form Module.

'Class1
Dim DT As ClsDateTime

Private Sub Class_Initialize()
  Set DT = New ClsDateTime
  Forms("Form2").Text2 = DT.DateTime
End Sub

Private Sub Class_Terminate()
 Set DT = Nothing

End Sub

The Class_Initialize() Subroutine, if present in the class module, runs immediately upon instantiating the Class Object. However, in our streamlined VBA coding, we are unable to utilize this feature. This limitation arises because we need to obtain the Form Object in the Class Module before executing the Class_Init() Subroutine. Consequently, we cannot use the Class_Initialize Subroutine. Instead, we call the Class_Init() Subroutine immediately after acquiring the Form Object in the Set Property Procedure of the Form Object.

That doesn't mean that we cannot use it at all. We can use it to instantiate the Collection Object or any other Objects used in this Class Module, like the following example:

Private Sub Class_Initialize()
	Set Coll = New Collection
End Sub

The Collection Object declaration is made in the Global declaration area of the Class Module. Since we used the New keyword in the Declaration Statement these extra lines of Code are not required within the Class_Initialize() Subroutine.

The Class_Terminate() Subroutine is useful to clean up memory and works like the Form_Unload() Event Procedure.

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

The above Code clears the Collection Object contents when the FLst_Object_Init Class Module Unloads from memory.

In this Project, we need only a single Wrapper Class Module for the Command Buttons on the Form, besides the Class Module FLst_Object_Init with the Class_Init() Subroutine.

The Command Button Class FLst_CmdButton has several subroutines and all of them are called individually from under each command Button Name from the Click Event Subroutine for clarity, rather than writing the entire Code directly under the Command Button name.

The FLst_CmdButton Class Module Code.

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

    Case "cmdFileDialog"
        Call cmdFileDialog 'Display selected Path & files
        
    Case "cmdDelLink"
        Call cmdDelLink 'Delete Selected Link from list
    
    Case "cmdDelAll"
        Call cmdDelAll 'Delete All Links from list
    
    Case "cmdDelFile"
        Call cmdDelFile 'Delete Link and File from Disk
        
    Case "cmdHelp"
        DoCmd.OpenForm "Help", acNormal 'Show help Form
End Select
End Sub

The cmdFileDialog() Subroutine.

This Subroutine is run by clicking on the Command Button with the Caption Create File Links.

Private Sub cmdFileDialog()
On Error GoTo cmdFileDialog_Click_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 "Excel WorkBooks", "*.xlsx; *.xlsm; *.xls; *.csv"
      .Filters.Add "Word Documents", "*.docx; *.doc"
      .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 & "*.*"
            cmdfrm.PathName = defPath
            cmdfrm.PathName.Requery
            strPath = defPath
         End If
            rst.AddNew
            'Create Hyperlink in 4 segments
            '1st segment: only the File Name
            strfiles = Mid(varFile, InStrRev(varFile, "\") + 1)
            '2nd segment:Full File PathName,3rd Empty,4th TipText
            strfiles = strfiles & "#" & varFile & "##Click"
            rst![FileLinks] = strfiles
            rst![Path] = varFile
            rst.Update
    Next
        
    Call ButtonStatus

        Else
            MsgBox "You clicked Cancel in the file dialog box."
        End If
      
   End With

cmdFileDialog_Click_Exit:
Exit Sub

cmdFileDialog_Click_Err:
MsgBox Err & " : " & Err.Description, , "cmdFileDialog_Click()"
Resume cmdFileDialog_Click_Exit
End Sub

The statement 'Set fDialog = Application.FileDialog(msoFileDialogFilePicker)' opens the File Browser Dialog Control and initializes its various properties. Within this control, we can define file type filters, allowing users to select specific file types from the filter display when the FileDialog control is open and displaying files from the default path setting. If there are any uncertainties about the file selection procedure, users can click on the Help Command Button located on the top right side of the form. This button provides detailed information about the functions of each command button on the form, explaining what they do and how to select files in different ways.

There is a table named DirectoryList designed to store the selected files in hyperlink format in the table's first column. The second column displays the full path of the files for reference. Clicking on the hyperlink will open the file in its native application, such as MS Word or Excel.

The Call ButtonStatus() statement invokes the ButtonStatus() subroutine, which checks whether the DirectoryList table is empty or not. If the table is empty, all command buttons except the 'Create File Links' and 'Help' buttons are disabled. This subroutine is called from within other subroutines and from the FLst_Object_Init class module. Please refer to the VBA code highlighted in red inside the Class_Init() subroutine above.

If you create a function within a stand-alone class module with public scope, it becomes accessible across other class modules or standard modules within the program. This allows you to call and utilize this function from outside the class module.

We will do some trial runs to learn how to call a Function from another Class Module, from the Standard Module, and from the Form Module after this Subroutines review.

The cmdDelLink Subroutine.

Select a single Record by clicking on the Record Selector Button, to delete it from the Hyperlink List, and click on the Delete Link Command Button. Before deleting the record a message is displayed to reconfirm the action or to Cancel it.

'Delete the Link From the List
Private Sub cmdDelLink()
On Error GoTo cmdDelLink_Click_Err
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strFile As String
Dim msg As String

'Read the current record Pathname
strFile = cmdfrm.DirectoryList.Form!Path
Set db = CurrentDb
Set rst = db.OpenRecordset("DirectoryList", dbOpenDynaset)
rst.FindFirst "Path = '" & strFile & "'"
If Not rst.NoMatch Then
    msg = UCase("Link: " & strFile & vbCr & "DELETE from above List?")
    
If MsgBox(msg, vbQuestion + vbYesNo, "cmddelLink_Click()") = vbYes Then
    rst.Delete
    rst.Requery
    cmdfrm.DirectoryList.Form.Requery
    MsgBox UCase("File Link: " & strFile & " Deleted.")
End If
Else
    MsgBox UCase("Link: " & strFile & " Not Found!!")
End If

Call ButtonStatus

rst.Close
Set rst = Nothing
Set db = Nothing

cmdDelLink_Click_Exit:
Exit Sub

cmdDelLink_Click_Err:
MsgBox Err & " : " & Err.Description, , "cmdDelLink_Click()"
Resume cmdDelLink_Click_Exit
End Sub

The cmdDelAll() Subroutine.

This Subroutine Deletes all the Records from the DirectoryList Table. All three Command Buttons with Delete actions are disabled and remain disabled till at least one file is added to the Hyperlink List.

Private Sub cmdDelAll()
Dim msg As String
Dim yn As Integer
Dim listcount As Long

On Error GoTo cmdDelAll_Click_Err
listcount = DCount("*", "DirectoryList")
If listcount = 0 Then
    cmdfrm.cmdDelAll.Enabled = False
    Exit Sub
Else
    cmdfrm.cmdDelAll.Enabled = True
End If

msg = "All File Links in the List will be Deleted!"
msg = msg & vbCr & "Are You sure?"
If MsgBox(msg, vbYesNo + vbCritical, "cmdDelAll()") = vbYes Then
    If MsgBox("Deleting All File Links?", vbOKCancel + vbInformation, "cmdDelAll()") = vbOK Then
        DoCmd.SetWarnings False
        DoCmd.OpenQuery "DeleteAll_LinksQ", acViewNormal
        DoCmd.SetWarnings True
        cmdfrm.DirectoryList.Form.Requery
        cmdfrm.cmdDelAll.Enabled = False
    End If
End If

Call ButtonStatus

cmdDelAll_Click_Exit:
Exit Sub

cmdDelAll_Click_Err:
MsgBox Err & " : " & Err.Description, , "cmdDelAll_Click()"
Resume cmdDelAll_Click_Exit
End Sub

The cmdDelFile() Subroutine.

Caution:

Be careful before using this Command Button. This Button Click will delete the File from the Disk and the Link from the list. Use this Command Button only to delete the file from the Disk.

'Caution: Deletes the File from Disk
'1. Delete the File from Disk
'2. Remove selected link from List
Private Sub cmdDelFile()
On Error GoTo cmdDelFile_Click_Err
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strFile As String
Dim msg As String

'Read selected Record Pathinfo
strFile = cmdfrm.DirectoryList.Form!Path
Set db = CurrentDb
Set rst = db.OpenRecordset("DirectoryList", dbOpenDynaset)
rst.FindFirst "Path = '" & strFile & "'"
If Not rst.NoMatch Then
    msg = UCase("File: " & strFile & vbCr & "DELETE from Disk?")
If MsgBox(msg, vbQuestion + vbYesNo, "cmdDelFile_Click") = vbYes Then
    
   If MsgBox(UCase("Are you sure you want to Delete") & vbCr _
   & UCase(rst!Path & " File from DISK?"), vbCritical + vbYesNo, "cmdDelFile_Click()") = vbNo Then
    GoTo cmdDelFile_Click_Exit
   End If
   'Delete record entry from Table DirectoryList
    rst.Delete
    rst.Requery
    
Call ButtonStatus

    'Delete file from Disk
    If Len(Dir(strFile)) > 0 Then
        Kill strFile
        MsgBox "File: " & strFile & " Deleted."
    Else
        MsgBox "File: " & strFile & vbCr & "Not Found on Disk!"
    End If
  End If
Else
    MsgBox "File: " & strFile & " Not Found!!"
End If

cmdDelFile_Click_Exit:
    rst.Close
    Set rst = Nothing
    Set db = Nothing
Exit Sub

cmdDelFile_Click_Err:
MsgBox Err & " : " & Err.Description, , "cmdDelFile_Click()"
Resume cmdDelFile_Click_Exit
End Sub

The ButtonStatus()

All three Delete Subroutines in the Flst_CmdButton and also from the FLst_Object_Init Class call this Public Subroutine ButtonStatus() to Disable the Command Buttons if the DirectoryList Table is Empty.

Public Sub ButtonStatus()
Dim listcount As Long

On Error GoTo ButtonsStatus_Err:

listcount = DCount("*", "DirectoryList")
cmdfrm.DirectoryList.Form.Requery

If listcount = 0 Then
    cmdfrm.cmdDelLink.Enabled = False
    cmdfrm.cmdDelAll.Enabled = False
    cmdfrm.cmdDelFile.Enabled = False
Else
    cmdfrm.cmdDelLink.Enabled = True
    cmdfrm.cmdDelAll.Enabled = True
    cmdfrm.cmdDelFile.Enabled = True
End If

ButtonsStatus_Exit:
Exit Sub

ButtonsStatus_Err:
MsgBox Err & " : " & Err.Description, , "ButtonsStatus()"
Resume ButtonsStatus_Exit
End Sub

Calling Public Function from Class Module.

Create a Class Module with the name ClsDateTime.

Copy and Paste the following Function Code into the Class Module:

Option Compare Database
Option Explicit

Public Function DateTime() As String
Dim fmt As String

fmt = "dd/mm/yyyy hh:nn:ss"
DateTime = "DateTime: " & Format(Now(), fmt)

End Function

Save the Class Module.
Create a New Form with the name Form1, or any other name you prefer and open it in Design View.
Add a TextBox Control on the Form and make sure the TextBox Name is Text0.
Display the Property Sheet of the Form and select the Other Tab in the Property Sheet.
Set the Has Module Property value to Yes to add a Class Module to the Form.
Display the Code Module of Form1, Copy and Paste the following Code in the Form Module, Save and Close the Form:
```
Private Sub Form_Load()
Dim DT As New ClsDateTime

Me.Text0 = DT.DateTime

End Sub
```
Open Form1 in Normal View. The current Date and Time will appear in the TextBox.

In the Form_Load() Event Procedure creates an Instance of the ClsDateTime Class Module with the object name DT. The next statement while entering DT. the DateTime() Function name will appear and all we have to do is to add the Function. When the Form is open the Date and Time information is displayed in the TextBox.

The same procedure can be repeated between two Class Modules to call the Function in another Class Module, instead of the Form Module.

We use three levels of Class Modules for our Streamlined Structured VBA Coding examples. Let us try this Function in a similar setup i.e. the Form Module, the Intermediary Class Module, and the Class Module with our DateTime() Function.

Make a Copy of Form1 and name it as Form2.
Rename the TextBox Name to Text2.
Display its Class Module, then Copy and Paste the following two Lines of Code, overwriting the existing lines.
```
Option Compare Database

Private test As New Class1
```
Create a Class Module with the Name Class1.

Copy and Pase the Following Code into the Class1 Module:

Option Compare Database

Private D  As New ClsDateTime

Private Sub Class_initialize()
  Forms("Form2").Text2 = D.DateTime
End Sub

Select Save from the File Menu to save all the Files.
Open Form2 in Normal View. The DateTime value should appear in Text2 TextBox on the Form.

Since Class Modules cannot load themselves in Memory we used Form2 Module to create an Instance of Class1 Module into memory. When Class1 Class Module is loaded into memory it creates an Instance of the ClsDateTime Class Module and executes the Class_Initialize() Subroutine. From within this Subroutine Calls the DateTime() Public Function. The result received is saved in the TextBox in Form2.

Hope you understand now how it works.

Try Calling the DateTime() Function from the Standard Module from a Test() Function.

Demo Database Download Link.

DirListing2K1.zip

Streamlining Form Module Code in Standalone Class Module.

Streamlining Form VBA Custom Report Wizard - 16

a.p.r. pillaiOctober 18, 2023 No comments

Streamlining Custom Made Reports Wizard Form Module VBA Code.

Hope you like the Custom Form Wizard of last week, which organized its VBA Code in standalone Class Modules. You can reach the Code and review and study them without interfering with the Form Design and Form Module.

The custom-made Form Wizard and the Report Wizard Forms have no difference in their User Interface Design. The Report Wizard was also published earlier, way back in December 2008 under Access 2003. Now, the Report Wizard Form Module VBA Codes run from the standalone Class Module to create the Reports.

The Report Wizard is designed using a TabControl with two Pages. The first TabPage displays the Wizard Type Options in a ListBox and the Table/Query list in a ComboBox Control.

1. Report in Column Format.

2. Report in Tabular Format.

The above two Options are inserted as Value List in the RowSource Property of the ListBox. The Default Value Property is set with the expression: = WizList.Column(0,0) to select the first item by default.

The ComboBox Control displays the list of Tables and Select-Queries filtered from the System Table MSysObjects. The ComboBox's Default Value Property is also set with the expression: =FilesList.Column(0,0) to select the first file as Default.

The SQL of the File Selection Query.

SELECT MSysObjects.Name
FROM MSysObjects
WHERE (((MSysObjects.Type)=1 Or (MSysObjects.Type)=5) AND ((Left([Name],4))<>'WizQ') AND ((Left([Name],1))<>'~') AND ((MSysObjects.Flags)=0))
ORDER BY MSysObjects.Type, MSysObjects.Name;

The TabControl first page image is given below:

Report Wizard Page2 Image:

The following lines of the VBA Code are only needed in the Form's Class Module. All other Events Subroutines and Functions are placed in the Standalone Class Modules.

Option Compare Database
Option Explicit

Private obj As New RWizObject_Init

Private Sub Form_Load()
    Set obj.fm_fom = Me
End Sub

The RWizObject_Init Intermediary Class Module is Instantiated with the Object Name obj in the global declaration area of the Form Module. In the Form_Load() Event Procedure the Form Object reference is passed to the RWizObject_Init Class Module Property Procedure through the statement Set obj.fm_fom = Me.

The RWizObject_Init Class.

The RWizObject_Init VBA Code is listed below. All the Report creation functions are placed within this Class Module.

Option Compare Database
Option Explicit

Private fom As Access.Form

Private cmdb As RWiz_CmdButton
Private lstb As RWiz_ListBox
Private comb As RWiz_Combo

Private tb As RWiz_TabCtl
Private Coll As New Collection

'Wizard Functions Running Command Button Instance'
'Functions are placed in this Module
Private WithEvents cmdFinish As Access.CommandButton
Dim DarkBlue As Long, twips As Long, xtyp As Integer, strFile As String

Public Property Get fm_fom() As Form
  Set fm_fom = fom
End Property

Public Property Set fm_fom(ByRef mfom As Form)
  Set fom = mfom
    
  Call Class_Init
End Property

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

'Filter Table/Select Query Names for ComboBox
Call Create_FilesList

For Each Ctl In fom.Controls
    Select Case Ctl.ControlType
        Case acTabCtl
            Set tb = New RWiz_TabCtl
            Set tb.Tb_Frm = fom
            Set tb.Tb_Tab = Ctl
              tb.Tb_Tab.OnChange = EP
              
              Coll.Add tb
            Set tb = Nothing
        
        Case acCommandButton
            Select Case Ctl.Name
                Case "cmdReport"
                    'Not to add in the Collection object
                    'The Click Event Runs the Wizard Functions
                    'from this Class Module, not from the
                    'Wrapper Class - FWiz_CmdButton
                    
                    Set cmdFinish = fom.cmdReport
                    cmdFinish.OnClick = EP
                Case Else
            
            Set cmdb = New RWiz_CmdButton
            Set cmdb.w_Frm = fom
            Set cmdb.w_cmd = Ctl
                cmdb.w_cmd.OnClick = EP
                
              Coll.Add cmdb
            Set cmdb = Nothing
         End Select
            
        Case acComboBox
            Set comb = New RWiz_Combo
            Set comb.cbo_Frm = fom
            Set comb.c_cbo = Ctl
                comb.c_cbo.OnGotFocus = EP
                comb.c_cbo.OnLostFocus = EP
            
        Case acListBox
            Set lstb = New RWiz_ListBox
            Set lstb.lst_Frm = fom
            Set lstb.m_lst = Ctl
                lstb.m_lst.OnGotFocus = EP
                lstb.m_lst.OnLostFocus = EP
                
                Coll.Add lstb
            Set lstb = Nothing
    End Select
Next
            
End Sub

Private Sub cmdFinish_Click()
        xtyp = fom!WizList
        strFile = fom!FilesList
        If xtyp = 1 Then
            Columns strFile
        Else
            Tabular strFile
        End If
          DoCmd.Close acForm, fom.Name
End Sub

Create_FilesList() Subroutine Code.

The Subroutine that creates the Files List for the ComboBox on the first page of the Wizard.

'Create Tables/Queries List for
Private Sub Create_FilesList()
Dim strSQL1 As String
Dim cdb As DAO.Database
Dim Qry As DAO.QueryDef
Dim FList As ComboBox

On Error GoTo Create_FilesList_Err
DoCmd.Restore

strSQL1 = "SELECT MSysObjects.Name " _
& "FROM MSysObjects " _
& "WHERE (((MSysObjects.Type)=1 Or (MSysObjects.Type)=5) " _
& "AND ((Left([Name],4))<>'WizQ') AND ((Left([Name],1))<>'~') " _
& "AND ((MSysObjects.Flags)=0)) " _
& "ORDER BY MSysObjects.Type, MSysObjects.Name;"

DarkBlue = 8388608
twips = 1440

Set cdb = CurrentDb
Set Qry = cdb.QueryDefs("WizQuery")
If Err = 3265 Then
  Set Qry = cdb.CreateQueryDef("WizQuery")
  Qry.SQL = strSQL1
  cdb.QueryDefs.Append Qry
  cdb.QueryDefs.Refresh
  Err.Clear
End If

With Forms("ReportWizard")
Set FList = .FilesList
    .FilesList.RowSource = "WizQuery"
    .FilesList.Requery
End With

Create_FilesList_Exit:
Exit Sub

Create_FilesList_Err:
MsgBox Err & ": " & Err.Description, , "Create_FilesList()"
Resume Create_FilesList_Exit
End Sub

The Function that Creates the Report in Column Format.

Public Function Columns(ByVal DataSource As String)

Dim cdb As Database
Dim FldList() As String
Dim Ctrl As Control
Dim Rpt As Report
Dim PgSection As Section
Dim DetSection As Section
Dim HdSection As Section

Dim lngTxtLeft As Long
Dim lngTxtTop As Long
Dim lngTxtHeight As Long
Dim lngtxtwidth As Long

Dim lngLblLeft As Long
Dim lngLblTop As Long
Dim lngLblHeight As Long
Dim lngLblWidth As Long

Dim FldCheck As Boolean
Dim strTblQry As String
Dim intflds As Integer
Dim lstcount As Long
Dim RptFields As ListBox
Dim j As Integer


'Create Report with Selected Fields

On Error Resume Next

strFile = DataSource
Set RptFields = fom.SelList
lstcount = RptFields.listcount

If lstcount = 0 Then
   MsgBox "Fields Not Selected for Report!"
   Exit Function
Else
   lstcount = lstcount - 1
End If

ReDim FldList(0 To lstcount) As String

Set cdb = CurrentDb
Set Rpt = CreateReport

Set HdSection = Rpt.Section(acPageHeader)
    HdSection.Height = 0.6667 * twips

Set DetSection = Rpt.Section(acDetail)
    DetSection.Height = 0.166 * twips

For j = 0 To lstcount
  FldList(j) = RptFields.ItemData(j)
Next

With Rpt
    .Caption = strFile
    .RecordSource = strFile
    lngtxtwidth = 1.5 * twips
    lngTxtLeft = 1.1 * twips
    lngTxtTop = 0.0417 * twips
    lngTxtHeight = 0.2181 * twips

    lngLblWidth = lngtxtwidth
    lngLblLeft = 0.073 * twips
    lngLblTop = 0.0417 * twips
    lngLblHeight = 0.2181 * twips
End With

For j = 0 To lstcount

   Set Ctrl = CreateReportControl(Rpt.Name, acTextBox, acDetail, , FldList(j), lngTxtLeft, lngTxtTop, lngtxtwidth, lngTxtHeight)
    With Ctrl
       .ControlSource = FldList(j)
       .FontName = "Comic Sans MS"
       .FontSize = 8
       .FontWeight = 700
       .ForeColor = DarkBlue
       .BorderColor = DarkBlue
       .Name = FldList(j)
       .BackColor = RGB(255, 255, 255)
       .BorderStyle = 1
       .SpecialEffect = 0
     Select Case (j / 9)
     	Case 1,2,3
        	lngTxtTop = (0.0417 * twips)
        	lngTxtLeft = lngTxtLeft + (2.7084 * twips)
        Case Else
        	lngTxtTop = lngTxtTop + .Height + (0.1 * twips)
     End Select
    End With

   Set Ctrl = CreateReportControl(Rpt.Name, acLabel, acDetail, FldList(j), FldList(j), lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
    With Ctrl
       .Caption = FldList(j)
       .Height = (0.2181 * twips)
       .Name = FldList(j) & " Label"
       .Width = twips
       .ForeColor = 0
       .BorderStyle = 0
       .FontWeight = 400
       Select Case (j/9)
       		Case 1,2,3
              lngLblTop = (0.0417 * twips)
        	  lngLblLeft = lngLblLeft + (2.7083 * twips)
       		Case Else
        	  lngLblTop = lngLblTop + .Height + (0.1 * twips)
       End Select
    End With
Next

lngLblWidth = 4.5 * twips
lngLblLeft = 0.073 * twips
lngLblTop = 0.0521 * twips
lngLblHeight = 0.323 & twips
lngLblWidth = 4.5 & twips
 Set Ctrl = CreateReportControl(Rpt.Name, acLabel, acPageHeader, , "Head1", lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
   With Ctrl
        .Caption = strFile
        .TextAlign = 2
        .Width = 4.5 * twips
        .Height = 0.38 * twips
        .ForeColor = DarkBlue
        .BorderStyle = 0
        .BorderColor = DarkBlue
        .FontName = "Times New Roman"
        .FontSize = 20
        .FontWeight = 700 ' Bold
        .FontItalic = True
        .FontUnderline = True
   End With

Page_Footer Rpt

DoCmd.OpenReport Rpt.Name, acViewPreview

Columns_Exit:
Exit Function

Columns_Err:
MsgBox Err.Description, , "Columns"
Resume Columns_Exit
End Function

The Tabular Type Report Creation Function.

The major part of the Code lines in both these Wizards are Variable declarations for defining the TextBox and for its Child Label Controls, and for their dimension values, other values like Font, Font Size, ForeColor, and other attribute values settings also come after the creation of these controls.

The statement Set Ctrl = CreateReportControl():

    Set Ctrl = CreateReportControl(Rpt.Name, acTextBox, _
   acDetail, , FldList(j), lngTxtLeft, lngTxtTop, lngtxtwidth, lngTxtHeight)

have several Parameters which need their values predefined before calling the CreateReportControl() Function. The first Parameter is the Report Name, next is the type of control (here the TextBox), where to create the Control (in the Detail Section), next is the Parent Parameter if it is a SubReport (here omitted), the fifth parameter is the Field Name and the next four parameters are the control's dimension values.

The Font and Color attributes of the control are set after its creation. Similarly, the TextBox control's Child Label Control is created next in the Page-Header Section of the Report.

In the above Column-Format Report, the Label Control is created in the Detail Section and to the left side of each TextBox Control. The TextBox is created after leaving enough space for the child-label control on the left side.

Public Function Tabular(ByVal DataSource As String)

Dim cdb As Database
Dim FldList() As String
Dim Ctrl As Control
Dim Rpt As Report
Dim PgSection As Section
Dim DetSection As Section

Dim lngTxtLeft As Long
Dim lngTxtTop As Long
Dim lngTxtHeight As Long
Dim lngtxtwidth As Long

Dim lngLblLeft As Long
Dim lngLblTop As Long
Dim lngLblHeight As Long
Dim lngLblWidth As Long

Dim FldCheck As Boolean
Dim strTblQry As String
Dim intflds As Integer
Dim lstcount As Long
Dim RptFields As ListBox
Dim j As Integer

'Create Report with Selected Fields

On Error Resume Next
strFile = DataSource

Set RptFields = fom.SelList
lstcount = RptFields.listcount

If lstcount = 0 Then
   MsgBox "Fields Not Selected for Report!"
   Exit Function
Else
   lstcount = lstcount - 1
End If

ReDim FldList(0 To lstcount) As String

Set cdb = CurrentDb

'Create Report Object
Set Rpt = CreateReport
Set PgSection = Rpt.Section(acPageHeader)
    PgSection.Height = 0.6667 * twips

Set DetSection = Rpt.Section(acDetail)
    DetSection.Height = 0.1667 * twips

For j = 0 To lstcount
  FldList(j) = RptFields.ItemData(j)
Next

With Rpt
    .Caption = strFile
    .RecordSource = strFile
    
    lngtxtwidth = 0.5 * twips
    lngTxtLeft = 0.073 * twips
    lngTxtTop = 0
    lngTxtHeight = 0.1668 * twips

    lngLblWidth = lngtxtwidth
    lngLblLeft = lngTxtLeft
    lngLblTop = 0.5 * twips
    lngLblHeight = lngTxtHeight
End With

For j = 0 To lstcount
   Set Ctrl = CreateReportControl(Rpt.Name, acTextBox, _
   acDetail, , FldList(j), lngTxtLeft, lngTxtTop, lngtxtwidth, lngTxtHeight)
    With Ctrl
       .ControlSource = FldList(j)
       .ForeColor = DarkBlue
       .BorderColor = DarkBlue
       .BorderStyle = 1
       .Name = FldList(j)
       lngTxtLeft = lngTxtLeft + (0.5 * twips)
    End With
   
   Set Ctrl = CreateReportControl(Rpt.Name, acLabel, _
   acPageHeader, , FldList(j), lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
   
    With Ctrl
       .Caption = FldList(j)
       .Name = FldList(j) & " Label"
       .Width = (0.5 * twips)
       .ForeColor = DarkBlue
       .BorderColor = DarkBlue
       .BorderColor = 0
       .BorderStyle = 1
       .FontWeight = 700 ' Bold
       lngLblLeft = lngLblLeft + (0.5 * twips)
    End With
Next

lngLblWidth = 4.5 * twips
lngLblLeft = 0.073 * twips
lngLblTop = 0.0521 * twips
lngLblHeight = 0.323 & twips
lngLblWidth = 4.5 & twips
 Set Ctrl = CreateReportControl(Rpt.Name, acLabel, acPageHeader, , "Head1", lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
   With Ctrl
        .Caption = strFile
        .TextAlign = 2
        .Width = 4.5 * twips
        .Height = 0.38 * twips
        .ForeColor = DarkBlue
        .BorderStyle = 0
        .BorderColor = DarkBlue
        .FontName = "Times New Roman"
        .FontSize = 16
        .FontWeight = 700 ' Bold
        .FontItalic = True
        .FontUnderline = True
   End With
On Error GoTo Tabular_Err

Page_Footer Rpt

DoCmd.OpenReport Rpt.Name, acViewPreview

Tabular_Exit:
Exit Function

Tabular_Err:
MsgBox Err.Description, , "Tabular"
Resume Tabular_Exit
End Function

The Page_Footer() Function Code.

This Function is called by both the Column and Tabular Wizards to create the Date and Page Numbers in the PageFooter Section of the Report.

Public Function Page_Footer(ByRef obj)
Dim lngWidth As Long, ctrwidth As Long, ctrlCount As Long
Dim j As Long, cdb As Database
Dim lngleft As Long, lngtop As Long, LineCtrl As Control, Ctrl As Control
Dim rptSection As Section, leftmost As Long, lngheight As Long
Dim rightmost As Long, RightIndx As Integer
'
'Note : The Controls appearing in Detail Section from left to Right
'       is not indexed 0 to nn in the order of placing,
'       instead 1st control placed in the Section has index value 0
'       irrespective of its current position.
'
On Error GoTo Page_Footer_Err

Set cdb = CurrentDb
Set rptSection = obj.Section(acDetail)

ctrlCount = rptSection.Controls.Count - 1

lngleft = rptSection.Controls(0).Left
rightmost = rptSection.Controls(0).Left

'indexed 0 control may not be the leftmost control on the Form/Report
'so find the leftmost control's left value
For j = 0 To ctrlCount
 leftmost = rptSection.Controls(j).Left
 
 If leftmost < lngleft Then
   lngleft = leftmost
 End If
 If leftmost > rightmost Then
   rightmost = leftmost
   RightIndx = j
 End If
Next
 
lngtop = 0.0208 * 1440
lngWidth = 0: ctrwidth = 0

   lngWidth = rightmost + rptSection.Controls(RightIndx).Width
   lngWidth = lngWidth - lngleft
   
  Set LineCtrl = CreateReportControl(obj.Name, acLine, acPageFooter, "", "", lngleft, lngtop, lngWidth, 0)
  Set Ctrl = LineCtrl
  LineCtrl.BorderColor = 12632256
  LineCtrl.BorderWidth = 2
  LineCtrl.Name = "ULINE"
  
lngtop = 0.0418 * 1440
lngleft = LineCtrl.Left
lngWidth = 2 * 1440
lngheight = 0.229 * 1440

'draw Page No control at the Report footer
Set LineCtrl = CreateReportControl(obj.Name, acTextBox, acPageFooter, "", "", lngleft, lngtop, lngWidth, lngheight)
With LineCtrl
   .ControlSource = "='Page : ' & [page] & ' / ' & [pages]"
   .Name = "PageNo"
   .FontName = "Arial"
   .FontSize = 10
   .FontWeight = 700
   .TextAlign = 1
End With
'draw Date Control at the right edge of the Line Control
'calculate left position of Date control

lngleft = (LineCtrl.Left + Ctrl.Width) - lngWidth
Set LineCtrl = CreateReportControl(obj.Name, acTextBox, acPageFooter, "", "", lngleft, lngtop, lngWidth, lngheight)
With LineCtrl
   .ControlSource = "='Date : ' & Format(Date(),'dd/mm/yyyy')"
   .Name = "Dated"
   .FontName = "Arial"
   .FontSize = 10
   .FontWeight = 700
   .TextAlign = 3
End With

Page_Footer_Exit:
Exit Function

Page_Footer_Err:
MsgBox Err & ": " & Err.Description, "Page_Footer()"
Resume Page_Footer_Exit
End Function

There are several Command Buttons on both Pages of the TabControl and all their Event Subroutines are run in the RWiz_CmdButton Wrapper Class. There is one Command Button on the second Page with the caption Finish that runs the Report Wizard's Functions. All the Wizard Functions are placed in the WizObject_Init Class Module. For that reason, a separate Command Button Control Instance is defined for the cmdFinish in the WizObject_Init Class Module. The Command Button name on the Form is cmdReport with the caption Finish. The cmdFinish Instance created in the Class Module is not added to the Collection Object after enabling the OnClick Event.

The Click Event Subroutine of this Command Button is written in the WizObject_Init Class Module so that the Report Wizard Functions can be called from this Module directly.

At the beginning of the Class_Init() Subroutine, the Create_FilesList() Function is called to create the ComboBox's source list of Tables and Select Queries, followed by the creation of ListBoxes, Command Buttons instances, enabling their Events and adding them to the Collection Object.

The cmdReport Click Event calls the Report Creation Function. The Column Type Report is not likely to be used, but it is useful for Label Printing.

The RWiz_CmdButton Class Module.

This Wrapper Class Module of CommandButton Object contains the following Command Button Click Event Subroutines.

Option Compare Database
Option Explicit

Private WithEvents cmd As CommandButton
Private frm As Form
Dim DarkBlue As Long, twips As Long, xtyp As Integer, strFile As String

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

Public Property Set w_Frm(ByRef wFrm As Form)
    Set frm = wFrm
End Property

Public Property Get w_cmd() As CommandButton
    Set w_cmd = cmd
End Property

Public Property Set w_cmd(ByRef wcmd As CommandButton)
    Set cmd = wcmd
End Property

Private Sub cmd_Click()
Dim lblInfo As String

  Select Case cmd.Name

    Case "cmdCancel2"
        DoCmd.Close acForm, frm.Name
               
    Case "cmdNext"
    If frm.SelList.listcount = 0 Then
        frm.cmdReport.Enabled = False
    Else
        frm.cmdReport.Enabled = True
    End If
    
  'Display the Wizard selection along with
  'the Table/Query selected in a Label Control
  'In the 2nd Page when the User Clicks
  'the cmdNext Command Button to display
  'the 2nd Page of the Wizard.
    lblInfo = "Table/Query: " & frm!FilesList
    If frm!WizList = 1 Then
        lblInfo = lblInfo & " - Column Report."
    Else
        lblInfo = lblInfo & " - Tabular Report."
    End If
    frm!info.Caption = lblInfo
    
 'Create the field List of the selected Table
 'and display them in the 1st ListBox on the
 '2nd Page of the Report Wizard.
       Call SelectTable
       
    Case "cmdCancel"
        DoCmd.Close acForm, frm.Name
        
    Case "cmdRight"
'Move the selected field to the Right=side ListBox.
'Multiselect option not given
        RightAll 1

    Case "cmdRightAll"
'Option Number Moves all the fields from
'Left side ListBox to the Right-side ListBox
        RightAll 2

    Case "cmdLeft"
        LeftAll 1
        
    Case "cmdLeftAll"
        LeftAll 2
    
    Case "cmdBack"
    'Go back to first Page. cancels the 2nd Page selections.
        frm.SelList.RowSource = "" 'Empty Selected field list
        frm.FilesList.RowSource = "WizQuery"
        frm.Page1.Visible = True
        frm.Page1.SetFocus
        frm.Page2.Visible = False
               
End Select
End Sub

Private Sub SelectTable()
Dim vizlist As ListBox
Dim lcount As Integer
Dim chkflag As Boolean
Dim FildList As ListBox
Dim strName As String
Dim strRSource As String
Dim cdb As DAO.Database
Dim doc As Document
Dim Tbl As DAO.TableDef
Dim Qry As DAO.QueryDef
Dim QryTyp As Integer
Dim FieldCount As Integer
Dim flag As Byte
Dim j As Integer

Set vizlist = frm.WizList
lcount = vizlist.listcount - 1

chkflag = False
For j = 0 To lcount
  If vizlist.Selected(j) = True Then
    xtyp = j + 1
    chkflag = True
  End If
Next

If IsNull(frm![FilesList]) = True Then
   MsgBox "Select a File from Table/Query List.", vbOKOnly + vbExclamation, "cmdNext"
   frm.WizList.Selected(0) = True
Else
   strFile = frm.FilesList
   frm.Page2.Visible = True
   frm.Page2.SetFocus
   frm.Page1.Visible = False
   
Set cdb = CurrentDb
flag = 0
For Each Tbl In cdb.TableDefs
    If Tbl.Name = strFile Then
       flag = 1
    End If
Next
For Each Qry In cdb.QueryDefs
    If Qry.Name = strFile Then
       flag = 2
    End If
Next
If flag = 1 Then
    Set Tbl = cdb.TableDefs(strFile)
    Set FildList = frm.FldList
    strRSource = ""
    FieldCount = Tbl.Fields.Count - 1
    For j = 0 To FieldCount
        If Len(strRSource) = 0 Then
            strRSource = Tbl.Fields(j).Name
        Else
            strRSource = strRSource & ";" & Tbl.Fields(j).Name
        End If
    Next
ElseIf flag = 2 Then
    Set Qry = cdb.QueryDefs(strFile)
    strRSource = ""
    FieldCount = Qry.Fields.Count - 1
    For j = 0 To FieldCount
        If Len(strRSource) = 0 Then
            strRSource = Qry.Fields(j).Name
        Else
            strRSource = strRSource & ";" & Qry.Fields(j).Name
        End If
    Next
End If

frm.FldList.RowSource = strRSource
frm.FldList.Requery
End If

End Sub

Private Function RightAll(ByVal SelectionType As Integer)
Dim FldList As ListBox, SelctList As ListBox, strRSource As String
Dim listcount As Long, j As Long, strRS2 As String

'On Error GoTo RightAll_Err
If SelectionType = 0 Then
   Exit Function
End If
Set FldList = Forms("ReportWizard").FldList
Set SelctList = Forms("ReportWizard").SelList

listcount = FldList.listcount - 1
strRSource = SelctList.RowSource: strRS2 = ""

Select Case SelectionType
    Case 1
        For j = 0 To listcount
            If FldList.Selected(j) = True Then
                If Len(strRSource) = 0 Then
                    strRSource = FldList.ItemData(j)
                Else
                    strRSource = strRSource & ";" & FldList.ItemData(j)
                End If
            Else
                If Len(strRS2) = 0 Then
                    strRS2 = FldList.ItemData(j)
                Else
                    strRS2 = strRS2 & ";" & FldList.ItemData(j)
                End If
            End If
        Next
        SelctList.RowSource = strRSource
        FldList.RowSource = strRS2
        SelctList.Requery
        FldList.Requery
    frm.cmdReport.Enabled = True
    Case 2

        For j = 0 To listcount
            If Len(strRSource) = 0 Then
                strRSource = FldList.ItemData(j)
            Else
                strRSource = strRSource & ";" & FldList.ItemData(j)
            End If
        Next
        SelctList.RowSource = strRSource
        FldList.RowSource = ""
        SelctList.Requery
        FldList.Requery
        frm.cmdCancel2.SetFocus
    If SelctList.listcount = 0 Then
        frm.cmdReport.Enabled = False
    End If
End Select
frm.cmdReport.Enabled = True

RightAll_Exit:
Exit Function

RightAll_Err:
MsgBox Err & ": " & Err.Description, , "RightAll"
Resume RightAll_Exit
End Function

Private Function LeftAll(ByVal SelectionType As Integer)
Dim FldList As ListBox, SelctList As ListBox, strRSource As String
Dim listcount As Long, j As Long, strRS2 As String

On Error GoTo LeftAll_Err

If SelectionType = 0 Then
   Exit Function
   
End If

Set FldList = Forms("ReportWizard").FldList
Set SelctList = Forms("ReportWizard").SelList

listcount = SelctList.listcount - 1
strRSource = FldList.RowSource: strRS2 = ""

Select Case SelectionType
    Case 1
        For j = 0 To listcount
            If SelctList.Selected(j) = True Then
                If Len(strRSource) = 0 Then
                    strRSource = SelctList.ItemData(j)
                Else
                    strRSource = strRSource & ";" & SelctList.ItemData(j)
                End If
            Else
                If Len(strRS2) = 0 Then
                    strRS2 = SelctList.ItemData(j)
                Else
                    strRS2 = strRS2 & ";" & SelctList.ItemData(j)
                End If
            End If
        Next
        SelctList.RowSource = strRS2
        FldList.RowSource = strRSource
        SelctList.Requery
        FldList.Requery
    If SelctList.listcount = 0 Then
        frm.cmdReport.Enabled = False
    End If
    Case 2
        For j = 0 To listcount
            If Len(strRSource) = 0 Then
                strRSource = SelctList.ItemData(j)
            Else
                strRSource = strRSource & ";" & SelctList.ItemData(j)
            End If
        Next
        SelctList.RowSource = ""
        FldList.RowSource = strRSource
        SelctList.Requery
        FldList.Requery
    If SelctList.listcount = 0 Then
        frm.cmdReport.Enabled = False
    End If
End Select
LeftAll_Exit:
Exit Function

LeftAll_Err:
MsgBox Err.Description, , "LeftAll"
Resume LeftAll_Exit

End Function

The Set of four Command Buttons, between the List Boxes on the second Page of the Wizard Form, controls the Field select/unselect operations. The first button moves the selected field from the first list to the second Listbox for the Report only one field at a time. The second Command Button with two greater-than symbols moves all the fields in the first ListBox to the 2nd ListBox.

The next Command Button removes the item selected from the second ListBox and places it back in the first ListBox. The fourth Command Button Click will remove all the List items selected earlier in the second ListBox for Report and move them all together back in the first ListBox.

The Back Command Button Click will empty the second ListBox and go back to the Report Wizard's first Page.

The RWiz_Combo Class Module Code

Option Compare Database
Option Explicit

Private cbofrm As Access.Form
Private WithEvents cbo As Access.ComboBox 'ComboBox object

'------------------------------------------------------
'Streamlining Form Module Code
'in Stand-alone Class Modules
'------------------------------------------------------
'ComboBox Wrapper Class
'Author: a.p.r. pillai
'Date  : 20/10/2023
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

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

Public Property Set cbo_Frm(ByRef cfrm As Form)
    Set cbofrm = cfrm
End Property

'TextBox Property GET/SET Procedures
Public Property Get c_cbo() As ComboBox
    Set c_cbo = cbo
End Property

Public Property Set c_cbo(ByRef pcbo As ComboBox)
    Set cbo = pcbo
End Property

Private Sub cbo_Click()
        cbofrm!FileList = Null

        cbofrm.TabCtl0.Pages(0).Visible = True
        cbofrm.TabCtl0.Pages(0).SetFocus
        cbofrm.TabCtl0.Pages(1).Visible = False
        cbofrm.TabCtl0.Pages(1).SetFocus
End Sub

Private Sub cbo_GotFocus()
    GFColor cbofrm, cbo
End Sub

Private Sub cbo_LostFocus()
    LFColor cbofrm, cbo
End Sub

The RWiz_ListBox Class Module Code.

Option Compare Database
Option Explicit

Private lstfrm As Access.Form
Private WithEvents lst As Access.ListBox

'------------------------------------------------------
'Streamlining Form Module Code
'in Stand-alone Class Modules
'------------------------------------------------------
'ListBox Wrapper Class
'Author: a.p.r. pillai
'Date  : 20/10/2023
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

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

Public Property Set lst_Frm(ByRef mFrm As Form)
    Set lstfrm = mFrm
End Property

'TextBox Property GET/SET Procedures
Public Property Get m_lst() As ListBox
    Set m_lst = lst
End Property

Public Property Set m_lst(ByRef mLst As ListBox)
    Set lst = mLst
End Property

Private Sub lst_Click()
Dim i As Integer

Select Case lst.Name
    Case "WizList"
        'Code
    Case "FldList"
        'Code
    Case "SelList"
        'Code
End Select

End Sub

Private Sub lst_GotFocus()
    GFColor lstfrm, lst
End Sub

Private Sub lst_LostFocus()
    LFColor lstfrm, lst
End Sub

The ListBox and ComboBox Class Module Subroutine Code highlights the Control when these controls receive the Focus.

The RWiz_TabCtl Class Module Code.

Option Compare Database
Option Explicit

Private tbFrm As Form
Private WithEvents tb As TabControl

'------------------------------------------------------
'Streamlining Form Module Code
'in Stand-alone Class Modules
'------------------------------------------------------
'Tab Control Events
'Author: a.p.r. pillai
'Date  : 20/10/2023
'Rights: All Rights(c) Reserved by www.msaccesstips.com
'------------------------------------------------------

Public Property Get Tb_Frm() As Form
    Set Tb_Frm = tbFrm
End Property

Public Property Set Tb_Frm(ByRef mFrm As Form)
    Set tbFrm = mFrm
End Property

Public Property Get Tb_Tab() As TabControl
    Set Tb_Tab = tb
End Property

Public Property Set Tb_Tab(ByRef mTab As TabControl)
    Set tb = mTab
End Property

Private Sub tb_Change()
Select Case tb.Value
    Case 0
        'MsgBox "Change Event: TabCtl.Page(0)"
    Case 1
        'MsgBox "Change Event: TabCtl.Page(1)"
End Select
        
End Sub

This Wrapper Class Module has the TabPage_Change() Event included for completeness, but not used for any purposes.

Download the Demo Database from the Link given below.

ReportWizard.zip

Streamlining Form Module Code in Standalone Class Module.

Streamlining Custom Made Form Wizard VBA - 15

a.p.r. pillaiOctober 09, 2023 No comments

Streamlined Custom Made Form Wizard.

This blog post was published earlier in December 2008 under Access 2003 and is now updated using the streamlined VBA Coding method in the standalone Class Modules.

The Form Wizard can create two Types of Forms, one in Column Format and the other in Tabular Format. Why do we need a custom Form Wizard, when Form and Report Wizards are already built-in to the Access System?

I was curious about the technique used in the built-in Form/Report Wizards. Additionally, I find creating tabular forms with fixed-length fields remarkably convenient for customization, especially when dealing with a substantial number of columns in an Access Form or Report.

The Forms Wizard is built using a TabControl with two Pages.

The First Page of the Wizard.

The ListBox on the top has Wizard Type Selection, Column Type, or Tubular Type Form.

The Combobox below will have the list of Tables and Query names, picked up from the Database System Table, with the use of a query, and added as Source Items of the Combobox.

The SQL of the Query is given below.

SELECT MSysObjects.Name
FROM MSysObjects
WHERE (((MSysObjects.Type)=1 Or (MSysObjects.Type)=5) AND ((Left([Name],4))<>'WizQ') AND ((Left([Name],1))<>'~') AND ((MSysObjects.Flags)=0))
ORDER BY MSysObjects.Type, MSysObjects.Name;

The options seen selected in both ListBox and ComboBox are selected by default. You may change the Options before proceeding to the next level by clicking on the Command Button with the Caption Next.

The Second Wizard Page Image.

The Selected Table or Query Fields will appear in the left-side ListBox Control. You may Add the required field by selecting the Field and then clicking on the > Button individually. If all the Fields are required then click on the >> Button.

Similarly, remove the selected Fields, if not required from the selected list of fields, using the left-side pointing arrow < or << Buttons. If no fields are selected the Command Button with the Finish caption will remain disabled.

When the required fields are selected Click on the Finish Command Button to create the Form and to open in Normal View.

The FormWizard Form Module VBA Code.

Option Compare Database
Option Explicit

Private obj As New FWizObject_Init

Private Sub Form_Load()
    Set obj.fm_fom = Me
End Sub

The FWizObject_Init Class Module contains the List of Object-level Wrapper Classes. The FWizObject_Init Class Module VBA Code is given below.

Option Compare Database
Option Explicit

Private fom As Access.Form

Private cmdb As FWiz_CmdButton
Private lstb As FWiz_ListBox
Private comb As FWiz_Combo

Private tb As FWiz_TabCtl
Private Coll As New Collection

'Wizard Functions Running Command Button Instance'
'Functions are placed in this Module
Private WithEvents cmdFinish As Access.CommandButton
Dim DarkBlue As Long, twips As Long, xtyp As Integer, strFile As String

Public Property Get fm_fom() As Form
  Set fm_fom = fom
End Property

Public Property Set fm_fom(ByRef mfom As Form)
  Set fom = mfom
    
  Call Class_Init
End Property

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

'Filter Table/Select Query Names for ComboBox
Call Create_FilesList

For Each Ctl In fom.Controls
    Select Case Ctl.ControlType
        Case acTabCtl
            Set tb = New FWiz_TabCtl
            Set tb.Tb_Frm = fom
            Set tb.Tb_Tab = Ctl
              tb.Tb_Tab.OnChange = EP
              
              Coll.Add tb
            Set tb = Nothing
        
        Case acCommandButton
            Select Case Ctl.Name
                Case "cmdForm"
                    'Not to add in the Collection object
                    'The Click Event Runs the Wizard Functions
                    'from this Class Module, not from the
                    'Wrapper Class - FWiz_CmdButton
                    
                    Set cmdFinish = fom.cmdForm
                    cmdFinish.OnClick = EP
                Case Else
            
            Set cmdb = New FWiz_CmdButton
            Set cmdb.w_Frm = fom
            Set cmdb.w_cmd = Ctl
                cmdb.w_cmd.OnClick = EP
                
              Coll.Add cmdb
            Set cmdb = Nothing
         End Select
            
        Case acComboBox
            Set comb = New FWiz_Combo
            Set comb.cbo_Frm = fom
            Set comb.c_cbo = Ctl
                comb.c_cbo.OnGotFocus = EP
                comb.c_cbo.OnLostFocus = EP
            
        Case acListBox
            Set lstb = New FWiz_ListBox
            Set lstb.lst_Frm = fom
            Set lstb.m_lst = Ctl
                lstb.m_lst.OnGotFocus = EP
                lstb.m_lst.OnLostFocus = EP
                
                Coll.Add lstb
            Set lstb = Nothing
    End Select
Next
            
End Sub

Private Sub cmdFinish_Click()
        xtyp = fom!WizList
        strFile = fom!FilesList
        If xtyp = 1 Then
            Columns strFile
        Else
            Tabular strFile
        End If
          DoCmd.Close acForm, fom.Name
End Sub

'Create Tables/Queries List for
Private Sub Create_FilesList()
Dim strSQL1 As String
Dim cdb As DAO.Database
Dim Qry As DAO.QueryDef
Dim FList As ComboBox

On Error GoTo Create_FilesList_Err
DoCmd.Restore

strSQL1 = "SELECT MSysObjects.Name " _
& "FROM MSysObjects " _
& "WHERE (((MSysObjects.Type)=1 Or (MSysObjects.Type)=5) " _
& "AND ((Left([Name],4))<>'WizQ') AND ((Left([Name],1))<>'~') " _
& "AND ((MSysObjects.Flags)=0)) " _
& "ORDER BY MSysObjects.Type, MSysObjects.Name;"

DarkBlue = 8388608
twips = 1440

Set cdb = CurrentDb
Set Qry = cdb.QueryDefs("WizQuery")
If Err = 3265 Then
  Set Qry = cdb.CreateQueryDef("WizQuery")
  Qry.SQL = strSQL1
  cdb.QueryDefs.Append Qry
  cdb.QueryDefs.Refresh
  Err.Clear
End If

With Forms("FormWizard")
Set FList = .FilesList
    .FilesList.RowSource = "WizQuery"
    .FilesList.Requery
End With

Create_FilesList_Exit:
Exit Sub

Create_FilesList_Err:
MsgBox Err & ": " & Err.Description, , "Create_FilesList()"
Resume Create_FilesList_Exit
End Sub

'Wizard Functions
Private Function Columns(ByVal DataSource As String)
'-------------------------------------------------------------------
'Author : a.p.r. pillai
'Date   : Sept-2000
'URL    : www.msaccesstips.com
'All Rights Reserved by www.msaccesstips.com
'-------------------------------------------------------------------
Dim cdb As Database
Dim FldList() As String
Dim Ctrl As Control
Dim frm As Form
Dim HdSection As Section
Dim DetSection As Section
Dim FrmFields As ListBox

Dim lngTxtLeft As Long
Dim lngTxtTop As Long
Dim lngTxtHeight As Long
Dim lngtxtwidth As Long

Dim lngLblLeft As Long
Dim lngLblTop As Long
Dim lngLblHeight As Long
Dim lngLblWidth As Long

Dim FldCheck As Boolean
Dim strTblQry As String
Dim intflds As Integer
Dim lstcount As Long
Dim j As Integer

'Create Form with Selected Fields
On Error GoTo Columns_Err

strFile = DataSource

Set FrmFields = Forms("FormWizard").SelList
lstcount = FrmFields.listcount

If lstcount = 0 Then
   MsgBox "Fields Not Selected for Form", , "FormWizard"
   Exit Function
Else
   lstcount = lstcount - 1
End If

ReDim FldList(0 To lstcount) As String

Set cdb = CurrentDb
Set frm = CreateForm
Application.RunCommand acCmdFormHdrFtr
With frm
    .DefaultView = 0
    .ViewsAllowed = 0
    .DividingLines = False
    .Section(acFooter).Visible = True
    .Section(acFooter).Height = 0.1667 * twips '0.1667 Inches
    .Section(acHeader).DisplayWhen = 0
    .Section(acHeader).Height = 0.5 * twips '0.5 Inches
End With

Set HdSection = frm.Section(acHeader)
    HdSection.Height = 0.6667 * twips

Set DetSection = frm.Section(acDetail)
    DetSection.Height = 0.166 * twips


For j = 0 To lstcount
  FldList(j) = FrmFields.ItemData(j)
Next

With frm
    .RecordSource = strFile
    .Caption = strFile

    lngtxtwidth = 1.25 * twips
    lngTxtLeft = 1.6694 * twips
    lngTxtTop = 0
    lngTxtHeight = 0.21 * twips

    lngLblLeft = 0.073 * twips
    lngLblTop = 0 '0.5 * twips
    lngLblWidth = 1.5208 * twips
    lngLblHeight = lngTxtHeight
End With

For j = 0 To lstcount

'Create Field Child Label
   Set Ctrl = CreateControl(frm.Name, acLabel, acDetail, _
   FldList(j), FldList(j), lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
    With Ctrl
       .Caption = FldList(j)
       .Name = FldList(j) & " Label"
       .Width = 1.5208 * twips
       .ForeColor = 0
       .BorderColor = 0
       .BorderStyle = 0
       .FontWeight = 400 ' Normal 700 ' Bold
       Select Case (1 / 9)
            Case 1, 2, 3
                lngLblTop = 0
                lngLblLeft = lngLblLeft + (2.7083 * twips)
            Case Else
                lngLblTop = lngLblTop + .Height + (0.1 * 1440)
       End Select
    End With

'Create Field TextBox
   Set Ctrl = CreateControl(frm.Name, acTextBox, acDetail, , _
   FldList(j), lngTxtLeft, lngTxtTop, lngtxtwidth, lngTxtHeight)
    With Ctrl
       .ControlSource = FldList(j)
       .FontName = "Arial"
       .FontSize = 10
       .Name = FldList(j)
       .BackColor = RGB(255, 255, 255)
       .ForeColor = 0
       .BorderColor = 9868950
       .BorderStyle = 1
       .SpecialEffect = 2
       
       Select Case (j / 9)
            Case 1, 2, 3
                lngTxtTop = 0
                lngTxtLeft = lngTxtLeft + (3.7084 * twips)
       Case Else
                lngTxtTop = lngTxtTop + .Height + (0.1 * twips)
       End Select
    End With

Next

'Create Heading Label
Call CreateHeading(frm)

Columns_Exit:
Exit Function

Columns_Err:
MsgBox Err.Description, , "Columns()"
Resume Columns_Exit
End Function


Private Function Tabular(ByVal DataSource As String)
'-------------------------------------------------------------------
'Author : a.p.r. pillai
'Date   : Sept-2000
'URL    : www.msaccesstips.com
'All Rights Reserved by www.msaccesstips.com
'-------------------------------------------------------------------
Dim cdb As Database
Dim FldList() As String
Dim Ctrl As Control
Dim frm As Form
Dim HdSection As Section
Dim DetSection As Section

Dim lngTxtLeft As Long
Dim lngTxtTop As Long
Dim lngTxtHeight As Long
Dim lngtxtwidth As Long

Dim lngLblLeft As Long
Dim lngLblTop As Long
Dim lngLblHeight As Long
Dim lngLblWidth As Long

Dim FldCheck As Boolean
Dim strTblQry As String
Dim intflds As Integer
Dim lstcount As Long
Dim FrmFields As ListBox
Dim j As Integer

'Create Form with Selected Fields
strFile = DataSource
On Error GoTo Tabular_Err

Set FrmFields = Forms("FormWizard").SelList
lstcount = FrmFields.listcount

If lstcount = 0 Then
   MsgBox "Fields Not Selected for the Form"
   Exit Function
Else
   lstcount = lstcount - 1
End If

ReDim FldList(0 To lstcount) As String

Set cdb = CurrentDb
Set frm = CreateForm
Application.RunCommand acCmdFormHdrFtr

With frm
    .DefaultView = 1
    .ViewsAllowed = 0
    .DividingLines = False
    .Section(acFooter).Visible = True
    .Section(acHeader).DisplayWhen = 0
    .Section(acHeader).Height = 0.5 * 1440
    .Section(acFooter).Height = 0.1667 * 1440
End With

Set HdSection = frm.Section(acHeader)
    HdSection.Height = 0.6667 * twips

Set DetSection = frm.Section(acDetail)
    DetSection.Height = 0.166 * twips


For j = 0 To lstcount
  FldList(j) = FrmFields.ItemData(j)
Next

With frm
    .Caption = strFile
    .RecordSource = strFile
    lngtxtwidth = 0.5 * twips 'Inches
    lngTxtLeft = 0.073 * twips
    lngTxtTop = 0
    lngTxtHeight = 0.166 * twips

    lngLblWidth = lngtxtwidth
    lngLblLeft = lngTxtLeft
    lngLblTop = 0.5 * twips
    lngLblHeight = lngTxtHeight
End With

For j = 0 To lstcount
 
'Create Fields in the Detail Section
   Set Ctrl = CreateControl(frm.Name, acTextBox, acDetail, , _
   FldList(j), lngTxtLeft, lngTxtTop, lngtxtwidth, lngTxtHeight)
    
    With Ctrl
       .ControlSource = FldList(j)
       .Name = FldList(j)
       .FontName = "Verdana"
       .Width = (0.5 * twips) 'Inches
       .FontSize = 8
       .ForeColor = 0
       .BorderColor = 12632256
       .BackColor = 16777215
       .BorderStyle = 1
       .SpecialEffect = 0
       lngTxtLeft = lngTxtLeft + (0.5 * twips)
    End With
   
'Field Heading Labels
   Set Ctrl = CreateControl(frm.Name, acLabel, acHeader, , _
   FldList(j), lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
    
    With Ctrl
       .Caption = FldList(j)
       .Name = FldList(j) & " Label"
       .Width = (0.5 * twips)
       .ForeColor = DarkBlue
       .BorderColor = DarkBlue
       .BorderStyle = 1
       .FontWeight = 700 ' Bold
       lngLblLeft = lngLblLeft + (0.5 * twips)
    End With
Next

'Heading Label
Call CreateHeading(frm)

Tabular_Exit:
Exit Function

Tabular_Err:
MsgBox Err & ": " & Err.Description, , "Tabular()"
Resume Tabular_Exit
End Function

Private Function CreateHeading(ByRef hFrm As Form)
Dim Ctl As Control
Dim lngLblLeft As Long
Dim lngLblTop As Long
Dim lngLblWidth As Long
Dim lngLblHeight As Long

On Error GoTo CreateHeading_Err

lngLblLeft = 0.073 * twips
lngLblTop = 0.0521 * twips
lngLblWidth = 1.5208 * twips
lngLblHeight = 0.323 & twips

'Create Heading Label
 Set Ctl = CreateControl(hFrm.Name, acLabel, acHeader, , _
 "Head1", lngLblLeft, lngLblTop, lngLblWidth, lngLblHeight)
   
   With Ctl
        .Caption = strFile
        .TextAlign = 2
        .Width = 4.5 * twips
        .Height = 0.38 * twips
        
        .ForeColor = DarkBlue
        .BorderStyle = 0
        .BorderColor = DarkBlue
        
        .FontName = "Arial"
        .FontSize = 18
        .FontWeight = 700 ' Bold
        .FontItalic = True
        .FontUnderline = True
   End With
   
DoCmd.OpenForm hFrm.Name, acNormal

CreateHeading_Exit:
Exit Function

CreateHeading_Err:
MsgBox Err & ": " & Err.Description, , "CreateHeading()"
Resume CreateHeading_Exit

End Function

There is a separate Command Button Instance with the name cmdFinish created in the Intermediate Class Module FWizObject_Init to run all the Wizard-related Functions placed in the main Class Module. The cmdFinish_Click() Event Procedure runs the Wizard Functions.

Private Sub cmdFinish_Click()
        xtyp = fom!WizList
        strFile = fom!FilesList
        If xtyp = 1 Then
            Columns strFile
        Else
            Tabular strFile
        End If
          DoCmd.Close acForm, fom.Name 'Closes the Wizard Form.
End Sub

Sample Form Images, both Column and Tabular Forms are created, using the Categories Table given below.

Wizard Created Form in Column Format.

Wizard Form in Tabular Format with Categories Table.

The Tabular Form is created with fixed-width Fields and needs to be modified with the required width of each Field.

The Command Buttons Wrapper Class: FWiz_CmdButton VBA Code.

The Command Button Wrapper Class Module FWiz_CmdButton VBA Code is given below for your Reference. Other Related Wrapper Classes contain a few lines of Event Procedure VBA Code you may open the Class Modules and study them from the attached Demo Database.

Option Compare Database
Option Explicit

Private WithEvents cmd As CommandButton
Private frm As Form
Dim DarkBlue As Long, twips As Long, xtyp As Integer, strFile As String

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

Public Property Set w_Frm(ByRef wFrm As Form)
    Set frm = wFrm
End Property

Public Property Get w_cmd() As CommandButton
    Set w_cmd = cmd
End Property

Public Property Set w_cmd(ByRef wcmd As CommandButton)
    Set cmd = wcmd
End Property

Private Sub cmd_Click()
Dim lblInfo As String

  Select Case cmd.Name

    Case "cmdCancel2"
        DoCmd.Close acForm, frm.Name
               
    Case "cmdNext"
    If frm.SelList.listcount = 0 Then
        frm.cmdForm.Enabled = False
    Else
        frm.cmdForm.Enabled = True
    End If
    
    lblInfo = "Table/Query: " & frm!FilesList
    If frm!WizList = 1 Then
        lblInfo = lblInfo & " - Columnar Form."
    Else
        lblInfo = lblInfo & " - Tabular Form."
    End If
    frm!info.Caption = lblInfo
       Call SelectTable
       
    Case "cmdCancel"
        DoCmd.Close acForm, frm.Name
        
    Case "cmdRight"
        RightAll 1

    Case "cmdRightAll"
        RightAll 2

    Case "cmdLeft"
        LeftAll 1
        
    Case "cmdLeftAll"
        LeftAll 2
    
    Case "cmdBack"
        frm.FilesList.RowSource = "WizQuery"
        frm.Page1.Visible = True
        frm.Page1.SetFocus
        frm.Page2.Visible = False
               
End Select
End Sub

Private Sub SelectTable()
Dim vizlist As ListBox, lcount As Integer, chkflag As Boolean
Dim FildList As ListBox, strName As String, strRSource As String
Dim cdb As Database, doc As Document
Dim Tbl As TableDef, Qry As QueryDef, QryTyp As Integer
Dim flag As Byte, FieldCount As Integer, j As Integer

Set vizlist = frm.WizList
lcount = vizlist.listcount - 1

chkflag = False
For j = 0 To lcount
  If vizlist.Selected(j) = True Then
    xtyp = j + 1
    chkflag = True
  End If
Next

If IsNull(frm![FilesList]) = True Then
   MsgBox "Select a File from Table/Query List.", vbOKOnly + vbExclamation, "cmdNext"
   frm.WizList.Selected(0) = True
Else
   strFile = frm.FilesList
   frm.Page2.Visible = True
   frm.Page2.SetFocus
   frm.Page1.Visible = False
   
Set cdb = CurrentDb
flag = 0
For Each Tbl In cdb.TableDefs
    If Tbl.Name = strFile Then
       flag = 1
    End If
Next
For Each Qry In cdb.QueryDefs
    If Qry.Name = strFile Then
       flag = 2
    End If
Next
If flag = 1 Then
    Set Tbl = cdb.TableDefs(strFile)
    Set FildList = frm.FldList
    strRSource = ""
    FieldCount = Tbl.Fields.Count - 1
    For j = 0 To FieldCount
        If Len(strRSource) = 0 Then
            strRSource = Tbl.Fields(j).Name
        Else
            strRSource = strRSource & ";" & Tbl.Fields(j).Name
        End If
    Next
ElseIf flag = 2 Then
    Set Qry = cdb.QueryDefs(strFile)
    strRSource = ""
    FieldCount = Qry.Fields.Count - 1
    For j = 0 To FieldCount
        If Len(strRSource) = 0 Then
            strRSource = Qry.Fields(j).Name
        Else
            strRSource = strRSource & ";" & Qry.Fields(j).Name
        End If
    Next
End If

frm.FldList.RowSource = strRSource
frm.FldList.Requery
End If

End Sub

Private Function RightAll(ByVal SelectionType As Integer)
Dim FldList As ListBox, SelctList As ListBox, strRSource As String
Dim listcount As Long, j As Long, strRS2 As String

On Error GoTo RightAll_Err
If SelectionType = 0 Then
   Exit Function
End If
Set FldList = Forms("FormWizard").FldList
Set SelctList = Forms("FormWizard").SelList

listcount = FldList.listcount - 1
strRSource = SelctList.RowSource: strRS2 = ""

Select Case SelectionType
    Case 1
        For j = 0 To listcount
            If FldList.Selected(j) = True Then
                If Len(strRSource) = 0 Then
                    strRSource = FldList.ItemData(j)
                Else
                    strRSource = strRSource & ";" & FldList.ItemData(j)
                End If
            Else
                If Len(strRS2) = 0 Then
                    strRS2 = FldList.ItemData(j)
                Else
                    strRS2 = strRS2 & ";" & FldList.ItemData(j)
                End If
            End If
        Next
        SelctList.RowSource = strRSource
        FldList.RowSource = strRS2
        SelctList.Requery
        FldList.Requery
    frm.cmdForm.Enabled = True
    Case 2

        For j = 0 To listcount
            If Len(strRSource) = 0 Then
                strRSource = FldList.ItemData(j)
            Else
                strRSource = strRSource & ";" & FldList.ItemData(j)
            End If
        Next
        SelctList.RowSource = strRSource
        FldList.RowSource = ""
        SelctList.Requery
        FldList.Requery
    frm.cmdForm.Enabled = False
End Select
frm.cmdForm.Enabled = True

RightAll_Exit:
Exit Function

RightAll_Err:
MsgBox Err.Description, , "RightAll"
Resume RightAll_Exit
End Function

Private Function LeftAll(ByVal SelectionType As Integer)
Dim FldList As ListBox, SelctList As ListBox, strRSource As String
Dim listcount As Long, j As Long, strRS2 As String

On Error GoTo LeftAll_Err

If SelectionType = 0 Then
   Exit Function
   
End If

Set FldList = Forms("FormWizard").FldList
Set SelctList = Forms("FormWizard").SelList

listcount = SelctList.listcount - 1
strRSource = FldList.RowSource: strRS2 = ""

Select Case SelectionType
    Case 1
        For j = 0 To listcount
            If SelctList.Selected(j) = True Then
                If Len(strRSource) = 0 Then
                    strRSource = SelctList.ItemData(j)
                Else
                    strRSource = strRSource & ";" & SelctList.ItemData(j)
                End If
            Else
                If Len(strRS2) = 0 Then
                    strRS2 = SelctList.ItemData(j)
                Else
                    strRS2 = strRS2 & ";" & SelctList.ItemData(j)
                End If
            End If
        Next
        SelctList.RowSource = strRS2
        FldList.RowSource = strRSource
        SelctList.Requery
        FldList.Requery
    If SelctList.listcount = 0 Then
        frm.cmdForm.Enabled = False
    End If
    Case 2
        For j = 0 To listcount
            If Len(strRSource) = 0 Then
                strRSource = SelctList.ItemData(j)
            Else
                strRSource = strRSource & ";" & SelctList.ItemData(j)
            End If
        Next
        SelctList.RowSource = ""
        FldList.RowSource = strRSource
        SelctList.Requery
        FldList.Requery
    If SelctList.listcount = 0 Then
        frm.cmdForm.Enabled = False
    End If
End Select
LeftAll_Exit:
Exit Function

LeftAll_Err:
MsgBox Err.Description, , "LeftAll"
Resume LeftAll_Exit

End Function