从表中生成 Access 报表
早在 2008 年，我做一些自由职业的工作，有机会参与这个 MS Access 报告项目。 客户处理员工福利、索赔和报销事宜。
早在 2008 年，我做一些自由职业的工作，有机会参与这个 MS Access 报告项目。 客户处理员工福利、索赔和报销事宜。 在那个时候参与这个项目很棒。 有大量的研究和辛勤工作。 虽然，我不认为自己是一个伟大的程序员或教练，但这个报告项目对小型组织、企业主、中级 VB 开发人员和报告开发人员来说非常有用。 我保持我的代码简洁明了。 如果你想使用部分代码或将该项目用作示例，请随意使用它。
使用代码
此应用程序创建四个报告：参与者、索赔、付款和报销。
用户可以按以下方式排序：参与者 ID、名字和姓氏。
用户可以通过社保号搜索生成四个报告之一，或者使用组合框选项按客户和参与者进行选择。
此程序包含
- 1 个主窗体，名为：XYZ 数据报告
- 13 个表格
- 11 个查询
- 4 个报告
代码中所需的Connection对象、Recordset对象、Command对象、公共字符串、整数和长整型变量的初始声明。
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
这些是用于应用程序生成报告的所有子例程/方法。
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()
大多数子例程都是不言自明的，并为开发人员提供了详细注释，以便理解子例程的作用。
Public Sub ConnectDB() 建立 ADODB (MS Access) 连接到您当前的项目路径。
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() 调用AddRefs 函数（在最后解释其作用）、ConnectDB 子例程，并使用客户列表填充组合框。
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) 是组合框的 BeforeUpdate 事件，当选中客户时，它将启用参与者组合框。 它将清除客户组合框，准备 SQL 字符串以根据客户填充参与者组合框。 您必须在每次加载时清除组合框，否则组合框将连接列表并继续增长。
'Clear Customer combo box
Do Until Me.cboCustomer.ListCount = 0
cboCustomer.RemoveItem (0)
Loop
组合框的列数为 2，因为您需要包含主键才能根据选择运行 SQL 命令。 但是，使列宽 =0";1"，以便键列不显示。 用户只能看到姓氏、名字等，这样用户更容易进行选择。 此外，在组合框中添加 "ALL" 项目，以便您可以为整个客户/参与者运行报告。
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() 一旦选择了客户组合框，根据该条件填充参与者组合框。 将此[cboClient.Value]传递给 SQL 字符串。 使用 Recordset 对象[objRST] 填充参与者的组合框。 完成Recordset [objRST] 和连接[objConn] 对象后，请确保关闭它们。
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() 是运行第一个报告（即参与者）的命令按钮。
首先，检查组合框是否为空，并与用户确认是否需要为所有客户和参与者运行报告。
' 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
SSN 选项卡上有一个 SSN 搜索功能，它需要 SQL 语句的单独条件。
如果用户提供了 SSN，则确保文本字段不为空。 这里没有对 SSN 进行验证，因此如果用户输入无效的 SSN，则不会为报告返回任何内容。
' 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
我为每个报告创建了 QueryDefs，它们基本上是具有已存储的查询定义的。
在每次单击期间，删除现有的那个并再次设置 QueryDef。
' 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 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
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
其他三个报告基本上都具有相同的逻辑，因此无需详细解释。
Private Sub cmdClaims_Click()
Private Sub cmdPayments_Click()
Private Sub cmdReimbursement_Click()
Function AddRefs() 最后，一个非常重要的函数，它将所需的引用列表与用户的列表进行比较。 它将自动添加应用程序运行所需的那些引用。 这将节省手动检查和添加那些必要引用的繁琐任务。 首先，它创建所需引用的数组列表并将其与用户的引用进行比较。 如果缺少，它将逐个添加它们。 最后，它调用隐藏的 SysCmd 以自动编译/保存所有模块。
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
最后，传递所有报告的参数（单选按钮：排序依据功能）。 所有报告都一样。
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