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")
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()
AddRefs
If intRunStat = 1 Then
Exit Sub
End If
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.
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)
If cboClient <> "" Then
cboCustomer.Enabled = True
End If
Do Until Me.cboCustomer.ListCount = 0
cboCustomer.RemoveItem (0)
Loop
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"
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()
Do Until Me.cboCustomer.ListCount = 0
cboCustomer.RemoveItem (0)
Loop
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"
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 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
MyString = "Yes"
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
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 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.
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.
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.
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 = ""
Msg = "Are you sure you want to run report for all participants ?"
Style = vbYesNo + vbQuestion + vbDefaultButton2
Title = "No Selection warning"
Help = "DEMO.HLP"
Ctxt = 1000
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 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
MyString = "Yes"
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
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:
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
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
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
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()
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
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")
intCount = Access.References.Count
nBounds = ((UBound(curRef) - LBound(curRef)) + 1)
i = 0
Do Until i > nBounds
j = 0
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 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
Me.OrderBy = Me.OpenArgs
Me.OrderByOn = True
End Sub