Generate Access Reports from Tables

• Download XYZ_Report.zip - 3.3 MB

Back in 2008, I was doing some freelance work and had a chance to work on this MS Access Report project. The client dealt with employee benefits, claims, and payment reimbursements. It was great working on this project during that time. There is good amount of research and hard work. Although, I don’t consider myself to be a great programmer or coach, this report project could come very handy to small organizations, business owners, intermediate VB Developers and Report developers. I keep my code clean and simple. If you want to use parts of the code or use the project as sample, feel free to use it.

Using the code

This application creates four reports: Participants, Claims, Payments, and Reimbursements.

User has the ability to sort by: Participant ID, First Name, and Last Name.

User can perform search by SSN to generate one of the 4 reports or select by Client and Participant using a combo box option.

This program contains

• 1 main form called: XYZ Data Report

  

• 13 tables

  

• 11 queries

  

• 4 reports

  

Initial declaration for Connection objects, Recordset object, Command object, public string, integer, and long variables required within the code.

Public objConn As ADODB.Connection
Public objRST As ADODB.Recordset
Public objCmd As ADODB.Command
Public strConn As String
Public strSQL As String
Public x As Long
Public intRunStat, nBounds As Integer
Public db As DAO.Database
Public qd As DAO.QueryDef

These are all the subroutines/methods used for the application to generate reports.

Public Sub ConnectDB()
Private Sub Form_Activate()
Private Sub cboClient_Change()
Private Sub cboClient_BeforeUpdate(Cancel As Integer)
Private Sub cmdParticipants_Click()
Private Sub cmdClaims_Click()
Private Sub cmdPayments_Click()
Private Sub cmdReimbursement_Click()
Private Sub cmdClear_Click()
Private Sub cmdReturn_Click()
Private Sub SSN_Click()
Function AddRefs()

Most of the subroutines are self-explanatory and well-commented for developers to understand what the sub does.

Public Sub ConnectDB() establishes ADODB (MS Access) connection to your current project path.

Public Sub ConnectDB()

    Set objConn = CreateObject("ADODB.Connection")
    Set objRST = CreateObject("ADODB.Recordset")
    Set objCmd = CreateObject("ADODB.Command")

    'Open your ADODB Connection
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\" & CurrentProject.Name & ";Persist Security Info=False;"
   
    objConn.Open (strConn)
   
    Set objCmd = Nothing
    Set objCmd = New ADODB.Command
    
    With objCmd
        .ActiveConnection = objConn
        .CommandType = adCmdText
        .CommandText = strSQL
        .CommandTimeout = 1000
        .Execute
    End With
    
    Set objRST = objCmd.Execute

End Sub

Private Sub Form_Activate() calls AddRefs function {explained towards the end what this does}, ConnectDB subroutine, and populates combobox with client list.

Private Sub Form_Activate()
        
    ' Call AddRefs function to compare reference list
    AddRefs
            
    If intRunStat = 1 Then
        Exit Sub
    End If
    'Clear Customer combo box
    Do Until Me.cboClient.ListCount = 0
        cboClient.RemoveItem (0)
    Loop
    
    cboCustomer.Enabled = False
    
    strSQL = ""
    strSQL = "SELECT tpa_client_tbl.cust_no, tpa_client_tbl.client_id, tpa_client_tbl.name FROM tpa_client_tbl ORDER BY tpa_client_tbl.name;"
    
    Call ConnectDB

    Me.cboClient.AddItem ("ALL")
    Do While objRST.EOF = False
        Me.cboClient.AddItem (objRST.Fields("name"))
        objRST.MoveNext
    Loop

End Sub

Private Sub cboClient_BeforeUpdate(Cancel As Integer) is a combobox BeforeUpdate event that will enable participant combobox when Client is selected. It will clear customer combo box, prepare SQL string to populate participant combobox based on Client. You must clear the combo box during each load or the combo box will concatenate the list and continue to grow.

'Clear Customer combo box
Do Until Me.cboCustomer.ListCount = 0
    cboCustomer.RemoveItem (0)
Loop

Combo box column count is 2 because you will need to include the Primary key to run sql commands based on selection. However, make the Column Widths =0";1" so the key column doesn’t show. Users can only see the last name, first name, etc. and it is easier for the user to perform the selection. In addition, add "ALL" item to the combo box, so you can run report for entire client/participant.

Me.cboCustomer.ColumnCount = 2
Me.cboCustomer.AddItem "ALL;ALL"

Private Sub cboClient_BeforeUpdate(Cancel As Integer)
    ' Enable Participant combo box if Client combo box is selected
    If cboClient <> "" Then
        cboCustomer.Enabled = True
    End If
    
    'Clear Customer combo box
    Do Until Me.cboCustomer.ListCount = 0
        cboCustomer.RemoveItem (0)
    Loop

    'Build SQL string
    strSQL = ""
    strSQL = "SELECT P.participant_id, P.lastname, H.participant_id, H.cust_no, T.client_id, T.name " & _
                "FROM personal AS P, hr_master AS H, tpa_client_tbl AS T " & _
                    "WHERE P.participant_id=H.participant_id AND H.cust_no=T.cust_no " & _
                        "AND T.name = """ & cboClient.Value & """ ORDER BY P.lastname; "

    Call ConnectDB

    Me.cboCustomer.ColumnCount = 2
    Me.cboCustomer.ColumnHeads = False
    Me.cboCustomer.AddItem "ALL;ALL"
    
    ' Populate participant combobox with user provided Client choice
    Do While objRST.EOF = False
        With cboCustomer
            .AddItem (objRST.Fields("P.participant_id").Value & _
                ";" & objRST.Fields("lastname").Value)
        objRST.MoveNext
        End With

Private Sub cboClient_Change() Once the Client combo box is selected, populate the participant combo box based on that criterion. Pass this [cboClient.Value] to SQL String. Use the Recordset object [objRST] to fill the combobox for Participant. Once done with Recordset [objRST] and connection [objConn] objects, make sure to close them.

Private Sub cboClient_Change()
    'Clear Customer combo box
    Do Until Me.cboCustomer.ListCount = 0
        cboCustomer.RemoveItem (0)
    Loop
    
    'Build SQL string
    strSQL = ""
        strSQL = "SELECT P.participant_id, P.lastname, H.participant_id, H.cust_no, T.client_id, T.name " & _
                    "FROM personal AS P, hr_master AS H, tpa_client_tbl AS T " & _
                        "WHERE P.participant_id=H.participant_id AND H.cust_no=T.cust_no " & _
                            "AND T.name = """ & cboClient.Value & """ ORDER BY P.lastname; "

    Call ConnectDB

    ' Populate Client Combo box
    Me.cboCustomer.ColumnCount = 2
    Me.cboCustomer.ColumnHeads = False
    Me.cboCustomer.AddItem "ALL;ALL"
    Do While objRST.EOF = False
        With cboCustomer
            .AddItem (objRST.Fields("P.participant_id").Value & _
                ";" & objRST.Fields("lastname").Value)
        objRST.MoveNext
        End With
    Loop

    If objRST.state = 1 Then
        objRST.Close
    End If
    
    If objConn.state = 1 Then
        objConn.Close
    End If
    intRunStat = 1

End Sub

Private Sub cmdParticipants_Click() is command button to run the first report, i.e., participant.

First of all, check to see if the combobox are empty and confirm with user if report need to be run for all client and participant.

' If users selects nothing from combo box, show warning to run report on all participants
    If Me.cboCustomer.Value = "" Or IsNull(Me.cboCustomer.Value) = True Or Me.cboCustomer.Value = "ALL" Then
        Screen.MousePointer = 0
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
        
        If Response = vbYes Then    ' User chose Yes.
            MyString = "Yes"
            'Build SQL string
            strSQL = "SELECT personal.participant_id, personal.lastname, personal.firstname, personal.address, personal.city, personal.state, personal.zip, personal.home_phone, personal.e_mail_addr, hr_master.soc_sec_no, hr_master.division_code " & _
                        " FROM personal INNER JOIN hr_master ON personal.participant_id = hr_master.participant_id "
        Else    ' User chose No.
            MyString = "No"
            Exit Sub
        End If

There is a SSN search functionality on the SSN tab which require separate condition for SQL statement.

If user provides a SSN, then ensure the text field is not empty. There is no validation for SSN here so if user inputs invalid SSN, nothing will be returned for the report.

' If User provides SSN, create query string to search by SSN
If Me.txtSSN.Value <> "" Or IsNull(Me.txtSSN.Value) = False Then
    strSQL = "SELECT personal.participant_id, personal.lastname, personal.firstname, personal.address, personal.city, personal.state, personal.zip, personal.home_phone, personal.e_mail_addr, hr_master.soc_sec_no, hr_master.division_code " & _
                " FROM personal INNER JOIN hr_master ON personal.participant_id = hr_master.participant_id " & _
                        " WHERE hr_master.soc_sec_no = '" & txtSSN.Value & "' "
    GoTo SearchBySSN_Continue
End If

I created QueryDefs for each of the report which is basically objects with stored definition of a query.

During each click, delete the existing one and set the QueryDef again.

' Delete existing QueryDef and create new one
For Each qd In db.QueryDefs
    If qd.Name = "PPTS" Then
        db.QueryDefs.Delete "PPTS"
        Exit For
    End If
Next

Set qd = CurrentDb.CreateQueryDef("PPTS", strSQL)

If there is nothing to show for the report, display the message, close recordset and connection.

' If no records are pulled, show msg and exit
With objRST
    If (.BOF = (True) And .EOF = (True)) Then
        MsgBox "No records returned based on your criteria", vbCritical, "PPT NOT Found!"
        objRST.Close
        objConn.Close
        Set objRST = Nothing
        Set objConn = Nothing
        Exit Sub
    End If
End With

qd.sql = strSQL

Set qd = Nothing
Set db = Nothing
Screen.MousePointer = 0

But before you generate the report, pass the radio button parameter for sort by option.

    ' Prepare Report as user selected Sort By option
    If Me.FrameSortBy.Value = 1 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "participant_id"
    ElseIf Me.FrameSortBy.Value = 2 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "lastname"
    ElseIf Me.FrameSortBy.Value = 3 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "firstname"
    End If
Private Sub cmdParticipants_Click()

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
    
    strSQL = ""

    ' Define message.
    Msg = "Are you sure you want to run report for all participants ?"
    ' Define buttons.
    Style = vbYesNo + vbQuestion + vbDefaultButton2
    ' Define title.
    Title = "No Selection warning"
    ' Define Help file.
    Help = "DEMO.HLP"
    ' Define topic
    Ctxt = 1000
        ' context.
        ' Display message.
        
    ' If User provides SSN, create query string to search by SSN
    If Me.txtSSN.Value <> "" Or IsNull(Me.txtSSN.Value) = False Then
        strSQL = "SELECT personal.participant_id, personal.lastname, personal.firstname, personal.address, personal.city, personal.state, personal.zip, personal.home_phone, personal.e_mail_addr, hr_master.soc_sec_no, hr_master.division_code " & _
                    " FROM personal INNER JOIN hr_master ON personal.participant_id = hr_master.participant_id " & _
                            " WHERE hr_master.soc_sec_no = '" & txtSSN.Value & "' "
        GoTo SearchBySSN_Continue
    End If

    ' If users selects nothing from combo box, show warning to run report on all participants
    If Me.cboCustomer.Value = "" Or IsNull(Me.cboCustomer.Value) = True Or Me.cboCustomer.Value = "ALL" Then
        Screen.MousePointer = 0
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
        
        If Response = vbYes Then    ' User chose Yes.
            MyString = "Yes"
            'Build SQL string
            strSQL = "SELECT personal.participant_id, personal.lastname, personal.firstname, personal.address, personal.city, personal.state, personal.zip, personal.home_phone, personal.e_mail_addr, hr_master.soc_sec_no, hr_master.division_code " & _
                        " FROM personal INNER JOIN hr_master ON personal.participant_id = hr_master.participant_id "
        Else    ' User chose No.
            MyString = "No"
            Exit Sub
        End If
    Else
            strSQL = "SELECT personal.participant_id, personal.lastname, personal.firstname, personal.address, personal.city, personal.state, personal.zip, personal.home_phone, personal.e_mail_addr, hr_master.soc_sec_no, hr_master.division_code " & _
                        " FROM personal INNER JOIN hr_master ON personal.participant_id = hr_master.participant_id " & _
                            " WHERE personal.participant_id = " & cboCustomer.Value & " "
    End If
      
SearchBySSN_Continue:
    ' Prepare SQL string for User selection for Sort By option
    If Me.FrameSortBy.Value = 1 Then
       strSQL = strSQL & " ORDER BY personal.participant_id ;"
    ElseIf Me.FrameSortBy.Value = 2 Then
       strSQL = strSQL & " ORDER BY personal.lastname ;"
    ElseIf Me.FrameSortBy.Value = 3 Then
       strSQL = strSQL & " ORDER BY personal.firstname ;"
    End If

    Set db = CurrentDb
    Set qd = Nothing
    
    ' Delete existing QueryDef and create new one
    For Each qd In db.QueryDefs
        If qd.Name = "PPTS" Then
            db.QueryDefs.Delete "PPTS"
            Exit For
        End If
    Next

    Set qd = CurrentDb.CreateQueryDef("PPTS", strSQL)
    
    Call ConnectDB
    
    ' If no records are pulled, show msg and exit
    With objRST
        If (.BOF = (True) And .EOF = (True)) Then
            MsgBox "No records returned based on your criteria", vbCritical, "PPT NOT Found!"
            objRST.Close
            objConn.Close
            Set objRST = Nothing
            Set objConn = Nothing
            Exit Sub
        End If
    End With
    
    qd.sql = strSQL
    
    Set qd = Nothing
    Set db = Nothing
    Screen.MousePointer = 0

    ' Prepare Report as user selected Sort By option
    If Me.FrameSortBy.Value = 1 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "participant_id"
    ElseIf Me.FrameSortBy.Value = 2 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "lastname"
    ElseIf Me.FrameSortBy.Value = 3 Then
        DoCmd.OpenReport "rptPersonal1", acViewPreview, , , , "firstname"
    End If

    If objRST.state = 1 Then
        objRST.Close
    End If
    
    If objConn.state = 1 Then
        objConn.Close
    End If

End Sub

The other three reports all have basically the same logic so there is no need to explain in detail.

Private Sub cmdClaims_Click()
Private Sub cmdPayments_Click()
Private Sub cmdReimbursement_Click()

Function AddRefs() Lastly, very important function which compares the required reference list to the user’s list. It will add those references automatically which is required for the application to run. This will save all the tedious task of manually checking and adding those necessary references. First, it creates the array list of required references and compares it with user’s references. If missing, it will add them one by one. Finally, it calls the hidden SysCmd to automatically compile/save all modules.

Function AddRefs()
' This function will compare VBA Reference list and add them from the array list if user doesn't have it
    Dim loRef As Access.Reference
    Dim intCount As Integer
    Dim intX As Integer
    Dim blnBroke As Boolean
    Dim strPath As String
    Dim curRef, disp
    Dim i, j As Integer
    
    On Error Resume Next

    ' Initialize Array List
    curRef = Array("C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB", _
                    "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll", _
                    "C:\Program Files\Common Files\Microsoft Shared\Web Components\10\OWC10.DLL", _
                    "C:\Program Files\Common Files\System\ado\msado25.tlb", _
                    "C:\WINXP\system32\stdole2.tlb", _
                    "C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE", _
                    "C:\Program Files\Common Files\Microsoft Shared\OFFICE12\MSO.DLL", _
                    "C:\Program Files\Common Files\System\ado\msjro.dll", _
                    "C:\Program Files\Microsoft Office XP\OFFICE11\MSACC.OLB", _
                    "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL")

    
    'Count the number of references in the database
    intCount = Access.References.Count
    
    'Loop through each reference in the database and determine if the reference is not there.
    'If this is the case, add the missing reference from the array list.
    nBounds = ((UBound(curRef) - LBound(curRef)) + 1)
    i = 0
    Do Until i > nBounds
        j = 0
        
        'Count the number of references in the database
        intCount = Access.References.Count
        
        Do Until intCount = 0
            Set loRef = Access.References(j)
            strPath = loRef.FullPath
            If strPath <> curRef(i) Then
                intCount = intCount - 1
                j = j + 1
                If intCount = 0 Then
                    Access.References.AddFromFile curRef(i)
                End If
            Else
                i = i + 1
                Exit Do
            End If
       
        Loop
        i = i + 1
    Loop

    ' Call a hidden SysCmd to automatically compile/save all modules.
    Call SysCmd(504, 16483)
End Function

Lastly, pass the arguments (radio button: sort by function) for all the reports. It is same for all reports.

Private Sub Report_Open(Cancel As Integer)
    DoCmd.Maximize
    
    ' Pass the Open Argument Sort by option selected by user
    Me.OrderBy = Me.OpenArgs
    Me.OrderByOn = True
End Sub