Here you go.
Option Compare Database
Option Explicit
Private lvClose As Boolean
Private Const iType = 1
Private Const iOperator = 2
Private Const iFilterForText = 3
Private Const iPassToReport = 4
Private Const iControlSource = 5
Private Sub cmdRunReport_Click()
On Error GoTo ErrCmdRun
Dim fm As Form
Dim ctl As Control
Dim i As Integer
Dim strReport As String
Dim strWhere As String
Dim strTemp As String
Dim strDispatcher As String
Dim strPlanner As String
Set fm = Forms!frmReportMenu
Call SetGvar("RptHeader", "")
strWhere = "1=1"
strReport = lstReports.Column(0)
' Build strWhere based on information Selected By User
Call SetGvar("FilterForText", "")
For Each ctl In fm
If Left(ctl.Name, 3) = "pck" Then
If ctl.Visible Then
Select Case ctl.Name
Case "pckCbo1", "pckCbo2", "pckCbo5", "pckCbo6"
If (Not IsNull(ctl)) Or (Not (ctl <> "")) Then
If getTag(ctl.Name, iPassToReport) = "True" Then
strWhere = strWhere & " AND " & getTag(ctl.Name,
iControlSource) & getTag(ctl.Name, iOperator) & getTag(ctl.Name, iType) & ctl
& getTag(ctl.Name, iType)
End If
If getTag(ctl.Name, iFilterForText) <> "" Then
Call SetGvar("FilterForText", GetGvar("FilterForText") &
getTag(ctl.Name, iFilterForText) & getTag(ctl.Name, iOperator) & ctl & vbCrLf)
End If
End If
Case "pckCbo3", "pckCbo4"
If strReport = "rptManufPerfByDispatcherPlanner" Then 'Added
by VM
If ctl.Name = "pckCbo4" Then
If (Not IsNull(pckCbo3)) And IsNull(pckCbo4) Then
'msgbox ("Only Dispatcher Selected!")
pckCbo3.SetFocus
strWhere = strWhere & " AND Category = 'Dispatcher' AND
CaseMailID = '" & pckCbo3.Text & "'"
ElseIf IsNull(pckCbo3) And (Not IsNull(pckCbo4)) Then
'msgbox ("Only Planner Selected!")
pckCbo4.SetFocus
strWhere = strWhere & " AND Category = 'Planner' AND
CaseMailID = '" & pckCbo4.Text & "'"
ElseIf (Not IsNull(pckCbo3)) And (Not IsNull(pckCbo4)) Then
'msgbox ("Both Dispatcher And Planner Selected!")
pckCbo3.SetFocus
strDispatcher = pckCbo3.Text
pckCbo4.SetFocus
strPlanner = pckCbo4.Text
strTemp = strWhere
strWhere = "(" & strWhere & " AND (Category =
'Dispatcher' AND CaseMailID = '" & strDispatcher & "'))" & _
" OR (" & strTemp & " AND (Category = 'Planner' AND
CaseMailID = '" & strPlanner & "'))"
ElseIf (IsNull(pckCbo3)) And (IsNull(pckCbo4)) Then
'msgbox ("Neither Dispatcher Nor Planner Selected!")
strTemp = strWhere
strWhere = "(" & strWhere & " AND Category =
'Dispatcher' AND TypeCode In ('2','3','5'))" & _
" OR (" & strTemp & " AND Category = 'Planner' AND
TypeCode = '4')"
Else
'msgbox ("Shouldn't reach here!!!")
End If
End If
Else 'Other Reports
If (Not IsNull(ctl)) Or (Not (ctl <> "")) Then
If getTag(ctl.Name, iPassToReport) = "True" Then
strWhere = strWhere & " AND " & getTag(ctl.Name,
iControlSource) & getTag(ctl.Name, iOperator) & getTag(ctl.Name, iType) & ctl
& getTag(ctl.Name, iType)
End If
If getTag(ctl.Name, iFilterForText) <> "" Then
Call SetGvar("FilterForText", GetGvar("FilterForText") &
getTag(ctl.Name, iFilterForText) & getTag(ctl.Name, iOperator) & ctl & vbCrLf)
End If
End If
End If
Case "pckStartDate1"
If IsNull(ctl) Or ctl = "" Then
ctl = "1/1/1900"
End If
If IsNull(Me!pckEndDate1) Or (Me!pckEndDate1 = "") Then
Me!pckEndDate1 = Date
End If
Call SetGvar("StartDate", pckStartDate1)
Call SetGvar("EndDate", pckEndDate1)
If getTag(ctl.Name, iPassToReport) = "True" Then
strWhere = strWhere & " AND " & getTag(ctl.Name, iControlSource)
& " BETWEEN #" & ctl & "# AND #" & _
Me("pckEndDate" & Right(ctl.Name, 1)) & "#"
End If
If getTag(ctl.Name, iFilterForText) <> "" Then
Call SetGvar("RptHeader", getTag(ctl.Name, iFilterForText) & "
between " & ctl & " and " & Me!pckEndDate1)
End If
Case "pckText1", "pckText2", "pckText3"
If (Not IsNull(ctl)) Or (Not (ctl <> "")) Then
If getTag(ctl.Name, iPassToReport) = "True" Then
strWhere = strWhere & " AND " & getTag(ctl.Name,
iControlSource) & getTag(ctl.Name, iOperator) & getTag(ctl.Name, iType) & ctl
& getTag(ctl.Name, iType)
End If
If getTag(ctl.Name, iFilterForText) <> "" Then
Call SetGvar("FilterForText", GetGvar("FilterForText") &
getTag(ctl.Name, iFilterForText) & vbTab & ctl & vbCrLf)
End If
End If
Case "pckLst1"
If (Not IsNull(ctl.Name)) Or (Not (ctl.Name <> "")) Then
strTemp = "("
For i = 0 To ctl.ListCount - 1
If ctl.Selected(i) Then
strTemp = strTemp & getTag(ctl.Name, iControlSource) & "=" &
getTag(ctl.Name, iType) & ctl.Column(0, i) & getTag(ctl.Name, iType) & " OR "
End If
Next i
If Len(strTemp) > 1 Then
strTemp = Left(strTemp, Len(strTemp) - 4)
strTemp = strTemp & ")"
strWhere = strWhere & " AND " & strTemp
End If
End If
Case Else
' Should Never Be Used
End Select
End If
End If
Next ctl
'Print or Preview Report
If Len(GetGvar("RptHeader")) > 1 Then
Call SetGvar("RptHeader", Right(GetGvar("RptHeader"),
Len(GetGvar("RptHeader")) - 4))
End If
Select Case optPrint
Case 1
DoCmd.OpenReport strReport, acViewPreview, , strWhere
Case 2
DoCmd.OpenReport strReport, , , strWhere
End Select
ExitCmdRun:
Set fm = Nothing
Set ctl = Nothing
Exit Sub
ErrCmdRun:
Select Case Err
Case 2501
Resume ExitCmdRun
Case Else
'Call ErrorLog(Me.Name, Err.Number)
msgbox Err.Number & ": " & Err.Description, , "Report Error"
Resume ExitCmdRun
Resume Next
End Select
End Sub
Private Sub Form_Load()
lstReports = Null
'Dim strsql As String
'strsql = "SELECT tblReportMenu.rptName, tblReportMenu.DisplayName FROM
tblReportMenu ORDER BY tblReportMenu.DisplayName"
'strsql = "SELECT tblReportMenu.rptName, tblReportMenu.DisplayName FROM
tblReportMenu WHERE (((tblReportMenu.SecLvl)<=getgvar('SecLvl'))) ORDER BY
tblReportMenu.DisplayName"
'Me!lstReports.RowSource = strsql
Me!lstReports.Requery
'lstReports.Requery
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SetGvar("RptHeader", "")
Cancel = Not lvClose
lvClose = False
End Sub
Private Sub lstReports_AfterUpdate()
On Error GoTo Err_lstReports
Dim fm As Form
Dim ctl As Control
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim iPrev As Integer
Dim iCur As Integer
Dim iCnt As Integer
Dim sTot As Single
Dim strsql As String
Dim sColWid As String
Dim sWidth As Single
DoCmd.Hourglass True
' Initialize Variables
Set db = currentDB
Set fm = Forms!frmReportMenu
'Reset the Form
For Each ctl In fm
If Left(ctl.Name, 3) = "pck" Then
If ctl.Visible Then
ctl = Null
End If
ctl.Visible = False
End If
Next ctl
'Prep the Controls if necessary
'Depending on the report selected the rowsource will change so that
'the user can select a specific item. Information is obtained from
'the table tblReportMenuSub
strsql = "SELECT * FROM tblReportMenuSub WHERE
(((tblReportMenuSub.rptName)='" & Me!lstReports & "'));"
Set rst = db.OpenRecordset(strsql)
Do While Not rst.EOF
Call storeTag(rst, rst!ShowControl)
Me(rst!ShowControl).RowSource = rst!RowSource
Me(rst!ShowControl).ColumnWidths = rst!ColumnWidth
Me(rst!ShowControl).Controls(0).Caption = rst!LabelCaption
Me(rst!ShowControl).StatusBarText = rst!ControlSource
If Not IsNull(rst!ColumnWidth) Then
sColWid = strReplaceAllInStr(rst!ColumnWidth, """", "") & ";"
iPrev = 1
iCur = InStr(1, sColWid, ";")
sWidth = CSng(Mid(sColWid, iPrev, iCur - iPrev))
sTot = sWidth
iCnt = 0
Do While iCur > 0
iCnt = iCnt + 1
iPrev = iCur
iCur = InStr(iCur + 1, sColWid, ";")
If iCur > 0 Then
sWidth = CSng(Mid(sColWid, iPrev + 1, iCur - iPrev - 1))
sTot = sTot + sWidth
End If
Loop
Me(rst!ShowControl).ColumnCount = iCnt ' + 1
Me(rst!ShowControl).ListWidth = CInt(sTot * 1440)
End If
Me(rst!ShowControl).Visible = True
Me(rst!ShowControl).Controls(0).Visible = True
rst.MoveNext
Loop
If Me.lstReports.Column(0) = "rptManufacturePerformance" Then
msgbox "This report will give you the orders that are DUE out of
manufacturing sorted by DDDTP. " & _
"This is inclusive of late orders and orders due.", vbOKOnly,
"Manufacturing Performance"
End If
If Me.lstReports.Column(0) = "rptMfgLate" Then
msgbox "This report will give you the orders that are LATE out of
manufacturing sorted by DDDTP.", vbOKOnly, "Manufacturing Performance"
End If
If Me.lstReports.Column(0) = "rptManufPerfPlantTotal" Then
msgbox "This report will give you the orders that are DUE out of
manufacturing sorted by DDTP. " & _
"This is inclusive of late orders and orders due for Make &
Purchase Parts.", vbOKOnly, "Manufacturing Performance - Plant Total"
End If
Exit_lstReports:
Set rst = Nothing
Set db = Nothing
Set ctl = Nothing
Set fm = Nothing
DoCmd.Hourglass False
cmdRunReport.Enabled = True
Exit Sub
Err_lstReports:
Select Case Err
Case 3061, 438, 3265, 13
Resume Next
Case Else
'Call ErrorLog(Me.Name, Err.Number)
msgbox Err & vbCrLf & Error$, vbOKOnly + VbExclamation, "Error..."
GoTo Exit_lstReports
Resume Next
End Select
End Sub
Private Function storeTag(rst As DAO.Recordset, sControl As String)
Dim sTag As String
sTag = "1:" & rst!Type
sTag = sTag & "2:" & rst!Operator
sTag = sTag & "3:" & rst!FilterForText
sTag = sTag & "4:" & rst!PassToReport
sTag = sTag & "5:" & rst!ControlSource
Me(sControl).Tag = sTag
End Function
Private Function strReplaceAllInStr(strString As String, strFind As String,
strReplace As String) As String
Dim intLoc As Integer
Dim strLeft As String
Dim strRight As String
Dim intLength As Integer
Dim intFind As Integer
Dim strTemp As String
Dim intReplace As Integer
intReplace = Len(strReplace)
strTemp = strString
intFind = Len(strFind)
intLoc = InStr(1, strTemp, strFind)
Do While intLoc > 0
strLeft = Left(strTemp, intLoc - 1)
intLength = Len(strTemp)
strRight = Right(strTemp, intLength - intLoc - intFind + 1)
strTemp = strLeft & strReplace & strRight
intLoc = InStr(intLoc + intReplace, strTemp, strFind)
Loop
strReplaceAllInStr = strTemp
End Function
Private Function getTag(sControl As String, iProperty As Integer) As Variant
Dim iStart As Integer
Dim iStop As Integer
Dim varReturn As Variant
Dim sTag As String
Dim sFind As String
sTag = Me(sControl).Tag
sFind = CStr(iProperty) & ":"
iStart = InStr(1, sTag, sFind) + 2
iStop = InStr(iStart + 1, sTag, ":") - 1
If iStop = -1 Then
iStop = Len(sTag) + 1
End If
If iStop = iStart Then
getTag = ""
Else
getTag = Mid(sTag, iStart, iStop - iStart)
End If
End Function
