Access VBA Checking for range of checkboxes with Dlookup (1 Viewer)

[Deke]

Hi All,
New here!

Hoping someone can help me. I'm self taught in VBA and this issue has stumped me.

I have a table "tblMtemp" there is a column for "PackNum"
What I'm trying to do is right some code that verifies that for "PackNum" there is at least one Checkbox checked.

In this example, 6788881 has at least one check box select (True) so this okay.
But pack 6788882 has no checkboxes select, this isn't okay.

I'm attempting to use a DLookup but I'm new to using them and that doesn't help when trying to figure out this logic.
Currently my code only seems to look at the top record. I can't do a look because then it wants to apply everything per record rather than by the range of PackNum

Here is the code I'm working with currently

Private Sub Okay_Button_Click()
Dim db As DAO.Database
Dim rs2 As DAO.Recordset
Dim strPack As String

Set db = CurrentDb
Set rs2 = CurrentDb.OpenRecordset("tblMtemp")
strPack = rs2.Fields("PackNum").Value

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Data Validation check that there is at least one box checks for each packnumber
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  If IsNull(DLookup("PackNum", "tblMtemp", rs2.Fields("PackNum") = " & strPack & ")) Then
           If DLookup("[PackNum]", "tblMtemp", rs2.Fields("Select") = False) Then
                  
   Else
            MsgBox "Please select at least one offer for Pack Number " & rs2.Fields("PackNum") & ""
                Exit Sub
            End If
End If
End Sub

Any help would be very greatly appreciated!
Thanks!
-Deke

 

[Isaac]

I would recommend looking at using Dcount

 

[Deke]

Could you be more specific? On which part? The whole thing or only one section of my code?

 

[Uncle Gizmo]

How about:-

Option Compare Database
Option Explicit

Private Sub btnTest_Click()
    Call fRSL_PackCount
End Sub

Private Sub fRSL_PackCount()
'RSL = Record Set Loop
Dim strSubName As String
Dim strModuleName As String

strSubName = "fRSL_PackCount"
strModuleName = "Form - " & Me.Name
'strModuleName = "basModNameHere"

On Error GoTo Error_Handler
   
    Dim curDB As DAO.Database
    Dim rst As DAO.Recordset

    Set curDB = CurrentDb

Dim strSQL_RSL As String
strSQL_RSL = "SELECT DISTINCT fPackNumb FROM tblOfferPack;"

    Dim strPackNumb As String
    Set rst = curDB.OpenRecordset(strSQL_RSL, dbOpenForwardOnly)
              
        Do Until rst.EOF
            strPackNumb = rst!fPackNumb
                If fProcessSQL(fPackSelected(strPackNumb)) = 2 Then
                    MsgBox " >>> Pack Number" & strPackNumb & " Has at least one Checkbox checked. "
                End If
            rst.MoveNext
        Loop
   
Exit_ErrorHandler:
        rst.Close
    Set rst = Nothing
    Set curDB = Nothing
   
    Exit Sub

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
       
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
           
            Select Case Err.Number
                 Case 0.123 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
            End Select
        Resume Exit_ErrorHandler

End Sub     'fRSL_PackCount

Private Function fProcessSQL(strSQL As String) As Byte
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
    rs.ActiveConnection = CurrentProject.Connection
    rs.CursorType = adOpenKeyset
    rs.Open strSQL
        Select Case rs.RecordCount
            Case Is = 0 '0 = No Matching Records
                fProcessSQL = 0
                rs.Close
                Exit Function
            Case Is >= 1  '2 = Two or more Matching Records
                fProcessSQL = 2
                rs.Close
                Exit Function
            Case Else   'A value other than an Interger was returned by the rs.RecordCount (Should Never happen)
                MsgBox "From Case Else"    'If you suspect a problem then activate this message box
                fProcessSQL = 0 '0 = No matching record
                rs.Close
                Exit Function
        End Select
End Function      'fProcessSQL

Private Function fPackSelected(ByVal strPackNumb As String) As String
Dim strSubName As String
Dim strModuleName As String

Dim conAppName As String
conAppName = "(Replace this Local Variable with a Global One) "

strSubName = "fPackSelected"
strModuleName = "Form - " & Me.Name
'strModuleName = "Module - basModuleName"

On Error GoTo Error_Handler

Dim strSQL0 As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strSQL4 As String

'Format Text Correctly for the SQL Statement - Delimiters " "
strPackNumb = Chr(34) & strPackNumb & Chr(34)

''Format Date Correctly for the SQL Statement - Delimiters # #
'strVar2 = Chr(35) & strVar2 & Chr(35)

'SELECT ID, fPackNumb, fSelect
'FROM tblOfferPack
'WHERE (((fPackNumb)=
'"6788881"
') AND ((fSelect)=True));


strSQL1 = "SELECT ID, fPackNumb, fSelect "
strSQL2 = "FROM tblOfferPack "
strSQL3 = "WHERE (((fPackNumb)="
'"6788881"
strSQL4 = ") AND ((fSelect)=True));"

strSQL0 = strSQL1 & strSQL2 & strSQL3 & strPackNumb & strSQL4

fPackSelected = strSQL0

Exit_ErrorHandler:
   
    Exit Function

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
       
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
           
            Select Case Err.Number
                Case 0.123 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Function      'fPackSelected

See Attached:-

 

[MajP]

? Maybe something simple

Public Function IsSelected(PackNum as long) as boolean
  isSelected = dcount("*","tblMtemp","PackNum = " & PackNum & " AND Select = -1")>0
end function

Or if Packnum is string

Public Function IsSelected(PackNum as string) as boolean
  isSelected = dcount("*","tblMtemp","PackNum = '" & PackNum & "' AND Select = -1")>0
end function

 

[Deke]

? Maybe something simple

Public Function IsSelected(PackNum as long) as boolean
  isSelected = dcount("*","tblMtemp","PackNum = " & PackNum & " AND Select = -1")>0
end function

Or if Packnum is string

Public Function IsSelected(PackNum as string) as boolean
  isSelected = dcount("*","tblMtemp","PackNum = '" & PackNum & "' AND Select = -1")>0
end function

Thanks for the response. Doesn't seem to work If I use it for an If statement it doesn't seem to recognize that anything is checked.

 

[Deke]

wow this is a lot to go through.... Thanks! I'll take a look and see where I come out with this.

How about:-

Option Compare Database
Option Explicit

Private Sub btnTest_Click()
    Call fRSL_PackCount
End Sub

Private Sub fRSL_PackCount()
'RSL = Record Set Loop
Dim strSubName As String
Dim strModuleName As String

strSubName = "fRSL_PackCount"
strModuleName = "Form - " & Me.Name
'strModuleName = "basModNameHere"

On Error GoTo Error_Handler
  
    Dim curDB As DAO.Database
    Dim rst As DAO.Recordset

    Set curDB = CurrentDb

Dim strSQL_RSL As String
strSQL_RSL = "SELECT DISTINCT fPackNumb FROM tblOfferPack;"

    Dim strPackNumb As String
    Set rst = curDB.OpenRecordset(strSQL_RSL, dbOpenForwardOnly)
             
        Do Until rst.EOF
            strPackNumb = rst!fPackNumb
                If fProcessSQL(fPackSelected(strPackNumb)) = 2 Then
                    MsgBox " >>> Pack Number" & strPackNumb & " Has at least one Checkbox checked. "
                End If
            rst.MoveNext
        Loop
  
Exit_ErrorHandler:
        rst.Close
    Set rst = Nothing
    Set curDB = Nothing
  
    Exit Sub

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
      
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
          
            Select Case Err.Number
                 Case 0.123 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo
            End Select
        Resume Exit_ErrorHandler

End Sub     'fRSL_PackCount

Private Function fProcessSQL(strSQL As String) As Byte
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
    rs.ActiveConnection = CurrentProject.Connection
    rs.CursorType = adOpenKeyset
    rs.Open strSQL
        Select Case rs.RecordCount
            Case Is = 0 '0 = No Matching Records
                fProcessSQL = 0
                rs.Close
                Exit Function
            Case Is >= 1  '2 = Two or more Matching Records
                fProcessSQL = 2
                rs.Close
                Exit Function
            Case Else   'A value other than an Interger was returned by the rs.RecordCount (Should Never happen)
                MsgBox "From Case Else"    'If you suspect a problem then activate this message box
                fProcessSQL = 0 '0 = No matching record
                rs.Close
                Exit Function
        End Select
End Function      'fProcessSQL

Private Function fPackSelected(ByVal strPackNumb As String) As String
Dim strSubName As String
Dim strModuleName As String

Dim conAppName As String
conAppName = "(Replace this Local Variable with a Global One) "

strSubName = "fPackSelected"
strModuleName = "Form - " & Me.Name
'strModuleName = "Module - basModuleName"

On Error GoTo Error_Handler

Dim strSQL0 As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strSQL4 As String

'Format Text Correctly for the SQL Statement - Delimiters " "
strPackNumb = Chr(34) & strPackNumb & Chr(34)

''Format Date Correctly for the SQL Statement - Delimiters # #
'strVar2 = Chr(35) & strVar2 & Chr(35)

'SELECT ID, fPackNumb, fSelect
'FROM tblOfferPack
'WHERE (((fPackNumb)=
'"6788881"
') AND ((fSelect)=True));


strSQL1 = "SELECT ID, fPackNumb, fSelect "
strSQL2 = "FROM tblOfferPack "
strSQL3 = "WHERE (((fPackNumb)="
'"6788881"
strSQL4 = ") AND ((fSelect)=True));"

strSQL0 = strSQL1 & strSQL2 & strSQL3 & strPackNumb & strSQL4

fPackSelected = strSQL0

Exit_ErrorHandler:
  
    Exit Function

Error_Handler:  'Version - 1a
    Dim strErrFrom As String
    Dim strErrInfo As String
      
        strErrFrom = "Error From:-" & vbCrLf & strModuleName & vbCrLf & "Subroutine >>>>>>> " & strSubName
        strErrInfo = "" & vbCrLf & "Error Number >>>>> " & Err.Number & vbCrLf & "Error Descscription:-" & vbCrLf & Err.Description
          
            Select Case Err.Number
                Case 0.123 'When Required, Replace Place Holder (1) with an Error Number
                    MsgBox "Error produced by Place Holder please check your code!" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
                Case Else
                    MsgBox "Case Else Error" & vbCrLf & vbCrLf & strErrFrom & strErrInfo, , conAppName
            End Select
        Resume Exit_ErrorHandler

End Function      'fPackSelected

 

[MajP]

Doesn't seem to work If I use it for an If statement it doesn't seem to recognize that anything is checked.

Yes it works with a modification for the bad choice of name. I tested it with the table and field names. Again if these are not numeric then you need to modify as shown. See demo query.

Public Function IsSelected(PackNum as long) as boolean
  isSelected = dcount("*","tblMtemp","PackNum = " & PackNum & " AND [Select] = -1")>0
end function

"Select" is a reserved word. This is a word that has special meaning in the Access/vba module. I would pick something else or you must put it in []

IsSelected or even Selected

 

[arnelgp]

using recordset, and return only records that has All Selected = False:

Private Sub Okay_Button_Click()
Dim db As DAO.Database
Dim rs2 As DAO.Recordset
Dim msg As String

Set db = CurrentDb
Set rs2 = CurrentDb.OpenRecordset( _
                "SELECT tblMtemp.PackNum, Count(IIf([Select]=False,1,Null)) AS Expr1 " & _
                "FROM tblMtemp " & _
                "GROUP BY tblMtemp.PackNum " & _
                "HAVING (((Count(IIf([Select]=False,1,Null)))=Count([Select])));")

With rs2
    If Not (.bof And .EOF) Then
        .movefirst
    End If
    Do Until .EOF
        msg = msg & ![packnum] & vbCrLf
        .movenext
    Loop
    .Close
End With
Set rs2 = Nothing
Set db = Nothing
If Len(msg) > 0 Then
    msg = Left$(msg, Len(msg) - Len(vbCrLf))
    msg = "Please select at least one offer for Pack Number(s):" & vbCrLf & vbCrLf & msg
    MsgBox msg
End If
End Sub

 

[Deke]

using recordset, and return only records that has All Selected = False:

Private Sub Okay_Button_Click()
Dim db As DAO.Database
Dim rs2 As DAO.Recordset
Dim msg As String

Set db = CurrentDb
Set rs2 = CurrentDb.OpenRecordset( _
                "SELECT tblMtemp.PackNum, Count(IIf([Select]=False,1,Null)) AS Expr1 " & _
                "FROM tblMtemp " & _
                "GROUP BY tblMtemp.PackNum " & _
                "HAVING (((Count(IIf([Select]=False,1,Null)))=Count([Select])));")

With rs2
    If Not (.bof And .EOF) Then
        .movefirst
    End If
    Do Until .EOF
        msg = msg & ![packnum] & vbCrLf
        .movenext
    Loop
    .Close
End With
Set rs2 = Nothing
Set db = Nothing
If Len(msg) > 0 Then
    msg = Left$(msg, Len(msg) - Len(vbCrLf))
    msg = "Please select at least one offer for Pack Number(s):" & vbCrLf & vbCrLf & msg
    MsgBox msg
End If
End Sub

this is exactly what I was looking for! Thank you soo much!

Also want to thank everyone who responded you helped me out more than you know and I learned a lot! really greatly appreciate the time you all took and the info you provided. I'll do my best to share what I learn!