Option Compare Database
Option Explicit
Dim SaveTyping As String
Private Sub cmdClear_Click()
Me.txtAgnBegin = ""
Me.txtAgnEnd = ""
Dim varItem As Variant
For Each varItem In Me.lstAgencyType.ItemsSelected
Me.lstAgencyType.Selected(varItem) = False
Next varItem
For Each varItem In Me.lstCaseManager.ItemsSelected
Me.lstCaseManager.Selected(varItem) = False
Next varItem
For Each varItem In Me.lstStatus.ItemsSelected
Me.lstStatus.Selected(varItem) = False
Next varItem
End Sub
Private Sub txtAgnBegin_KeyUp(KeyCode As Integer, Shift As Integer)
SaveTyping = Me.txtAgnBegin.Text
End Sub
Private Sub txtAgnBegin_LostFocus()
Me.txtAgnBegin = SaveTyping
End Sub
Private Sub txtAgnEnd_KeyUp(KeyCode As Integer, Shift As Integer)
SaveTyping = Me.txtAgnEnd.Text
End Sub
Private Sub txtAgnEnd_LostFocus()
Me.txtAgnEnd = SaveTyping
End Sub
Private Sub btnAgency_Click()
Me.gfAgency.Visible = _
Not Me.gfAgency.Visible
End Sub
Private Sub btnProgStat_Click()
Me.gfProgStat.Visible = _
Not Me.gfProgStat.Visible
End Sub
Private Sub Report_Load()
Me.gfAgency.Visible = False
Me.gfProgStat.Visible = False
End Sub
'************************** Õ¿Õ- **************************
'*** Coded by Martin Green ******* martin@fontstuff.com ***
'******* Office Tips Web Site - www.fontstuff.com *********
'**********************************************************
' This code uses ADO and ADOX and is suitable for Access 2000 (and later).
' A reference must be set to Microsoft ADO Ext. 2.7 for DDL and Security.
Private Sub cmdOK_Click()
On Error GoTo cmdOK_Click_Err
Dim blnQueryExists As Boolean
Dim cat As New ADOX.Catalog
Dim cmd As New ADODB.Command
Dim qry As ADOX.View
Dim varItem As Variant
Dim strAgencyType As String
Dim strCaseManager As String
Dim strStatus As String
Dim strCaseManagerCondition As String
Dim strStatusCondition As String
Dim strSQL As String
'Added (from code by Allen Browne) for date filter
Dim strDateFilter As String
Dim strDateField As String
Const strcJetDate = "\#mm\/dd\/yyyy\#" 'Do NOT change it to match your local settings.
' Check for the existence of the stored query
blnQueryExists = False
Set cat.ActiveConnection = CurrentProject.Connection
For Each qry In cat.Views
If qry.Name = "qryAgencySelectQuery" Then
blnQueryExists = True
Exit For
End If
Next qry
' Create the query if it does not already exist
' Added ( " & _) at end of first line and the where clause for Date Filter (not working yet)
If blnQueryExists = False Then
cmd.CommandText = "SELECT * FROM qryAgencyInvolvTypeQuery " & _
"WHERE qryAgencyInvolvTypeQuery.[start Date] " & strDateFilter & ";"
cat.Views.Append "qryAgencySelectQuery", cmd
End If
Application.RefreshDatabaseWindow
' Turn off screen updating
DoCmd.Echo False
' Close the query if it is already open
If SysCmd(acSysCmdGetObjectState, acQuery, "qryAgencySelectQuery") = acObjStateOpen Then
DoCmd.Close acQuery, "qryAgencySelectQuery"
End If
' Code originally by Allen Browne- Build criteria string for the date filter. (not working)
strDateField = "qryAgencyInvolvTypeQuery.[Start Date]"
If IsDate(Me.txtAgnBegin) Then
strDateFilter = "(" & strDateField & " >= " & Format(Me.txtAgnBegin, strcJetDate) & ")"
End If
If IsDate(Me.txtAgnEnd) Then
If strDateFilter <> vbNullString Then
strDateFilter = strDateFilter & " AND "
End If
strDateFilter = strDateFilter & "(" & strDateField & " < " & Format(Me.txtAgnEnd + 1, strcJetDate) & ")"
End If
' Build criteria string for AgencyType
For Each varItem In Me.lstAgencyType.ItemsSelected
strAgencyType = strAgencyType & "," & Me.lstAgencyType.ItemData(varItem) & ""
Next varItem
If Len(strAgencyType) = 0 Then
strAgencyType = "Like '*'"
Else
strAgencyType = Right(strAgencyType, Len(strAgencyType) - 1)
strAgencyType = "IN(" & strAgencyType & ")"
End If
' Build criteria string for CaseManager
For Each varItem In Me.lstCaseManager.ItemsSelected
strCaseManager = strCaseManager & "," & Me.lstCaseManager.ItemData(varItem) & ""
Next varItem
If Len(strCaseManager) = 0 Then
strCaseManager = "Like '*'"
Else
strCaseManager = Right(strCaseManager, Len(strCaseManager) - 1)
strCaseManager = "IN(" & strCaseManager & ")"
End If
' Build criteria string for Status
For Each varItem In Me.lstStatus.ItemsSelected
strStatus = strStatus & ",'" & Me.lstStatus.ItemData(varItem) & "'"
Next varItem
If Len(strStatus) = 0 Then
strStatus = "Like '*'"
Else
strStatus = Right(strStatus, Len(strStatus) - 1)
strStatus = "IN(" & strStatus & ")"
End If
' Get CaseManager condition
If Me.optAndCaseManager.Value = True Then
strCaseManagerCondition = " AND "
Else
strCaseManagerCondition = " OR "
End If
' Get Status condition
If Me.optAndStatus.Value = True Then
strStatusCondition = " AND "
Else
strStatusCondition = " OR "
End If
' Build SQL statement
strSQL = "SELECT qryAgencyInvolvTypeQuery.* FROM qryAgencyInvolvTypeQuery " & _
"WHERE qryAgencyInvolvTypeQuery.[Agency Type] " & strAgencyType & _
strCaseManagerCondition & "qryAgencyInvolvTypeQuery.[CaseManager] " & strCaseManager & _
strStatusCondition & "qryAgencyInvolvTypeQuery.[Status] " & strStatus & ";"
' Apply the SQL statement to the stored query
cat.ActiveConnection = CurrentProject.Connection
Set cmd = cat.Views("qryAgencySelectQuery").Command
cmd.CommandText = strSQL
Set cat.Views("qryAgencySelectQuery").Command = cmd
Set cat = Nothing
' Open the Query
DoCmd.OpenQuery "qryAgencySelectQuery"
' If required the dialog can be closed at this point
' DoCmd.Close acForm, Me.Name
' Restore screen updating
cmdOK_Click_Exit:
DoCmd.Echo True
Exit Sub
cmdOK_Click_Err:
MsgBox "An unexpected error hass occurred." _
& vbCrLf & "Procedure: cmdOK_Click" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description:" & Err.Description _
, vbCritical, "Error"
Resume cmdOK_Click_Exit
End Sub
Private Sub optAndCaseManager_Click()
' Toggle option buttons
If Me.optAndCaseManager.Value = True Then
Me.optOrCaseManager.Value = False
Else
Me.optOrCaseManager.Value = True
End If
End Sub
Private Sub optAndStatus_Click()
' Toggle option buttons
If Me.optAndStatus.Value = True Then
Me.optOrStatus.Value = False
Else
Me.optOrStatus.Value = True
End If
End Sub
Private Sub optOrCaseManager_Click()
' Toggle option buttons
If Me.optOrCaseManager.Value = True Then
Me.optAndCaseManager.Value = False
Else
Me.optAndCaseManager.Value = True
End If
End Sub
Private Sub optOrStatus_Click()
' Toggle option buttons
If Me.optOrStatus.Value = True Then
Me.optAndStatus.Value = False
Else
Me.optAndStatus.Value = True
End If
End Sub
