Streamlining Custom Made Form Wizard VBA - 15 ~ LEARN MS-ACCESS TIPS AND TRICKS

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