Having trouble with multi-select list box in Access

From: Walter (Waljock_at_sbcglobal.net)
Date: 02/10/05 

Date: Thu, 10 Feb 2005 08:20:20 -0800

Here is a VBA solution your problem:

Option Compare Database
Option Explicit

'*******************************************
'* Constant Declarations for this module *
'*******************************************

    Const mstrcTagID As String
= "Where=" 'Tag Property identifier to build
Where Clause
    Const mstrcRange_Begin As String
= "_BeginR" 'String to be appended to the base name
of a control that represents the Begin part of a range
    Const mstrcRange_End As String
= "_EndR" 'String to be appended to the base
name of a control that represents the End part of a range
    Const mstrcDateSymbol
= "#" 'Symbol for dates (i.e. Date
= #10/24/2004#)
    Const mstrcFldSeparator
= "," 'Separates items with Where=
Tag
    Const mstrcStringSymbol
= "'" 'Symbol for strings (i.e.
where name = 'dog')
    Const mstrcTagSeparator
= ";" 'Separates Tag items in
controls Tag Property
    
'+*********************************************************
***********************************
'*
'$ Function: BuildWhere
'*
'* Author: FancyPrairie
'*
'* Date: October, 1998
'*
'* Purpose: This routine will build a Where clause
based on the items the user selected/entered on a
'* Report Criteria form (or any type of form
that the caller may use to build a Where clause
'* based on the items selected).
'*
'* This routine assumes that, in order for
the control to be included in the criteria,
'* it must satisfy the following conditions:
'*
'* 1. Tag Property must contain:
Where=TableName.FieldName,FieldType[,Operator,Value]
'* a. TableName.FieldName is the
name of the Table and field to filter on
'* (example:
tblEmployee.lngEmpID)
'* b. FieldType must be one of the
following words: String, Date
'* (Note: String and Date are
the only ones that have special meaning at this time
'* (' or #). However,
if the FieldType is not String or Date then set
'* you can leave the
FieldType empty or (anticipating future uses) set the
FieldType
'* to Long, Integer,
Byte, Single, Double, Boolean.)
'* c. Operator (optional) can be
one of the following: = <> < > <= >= Like IsNull
'* (Default is =)
'* d. Value (optional) to be
filtered on (more for option groups and check boxes)
'* (Note: This is primarily
intended to be used by Option groups and check boxes.
'* For example, suppose
you have a check box. If the box is checked, then
'* the you need to set
the Value argument equal to True and the FieldType
'* should be set to
Boolean. Else Value should be set to False.)
'* 2. Control must be Enabled
'* 3. Control must be visible
'* 4. If the control is part of a range,
then the name of the control must end with
'* either _BeginR (begin range
control) or _EndR (end range control)
'*
'* As of this writing, the following controls
are checked:
'* 1. List Boxes (multiselect and single
select)
'* 2. Ranges (2 controls that are grouped
together (i.e. Begin and End Dates)
'* 3. Text Boxes
'* 4. Combo Boxes
'* 5. Option Groups
'* 6. Check Boxes
'*
'* Arguments: frm (form)
'* ----------
'* Represents the form (Report Criteria form)
that contains the controls
'* from which the Where clause is to be
created.
'*
'* varCtl (ParamArray)
'* -------------------
'* Indicates which controls you want
checked. If this argument is missing then
'* this routine loops thru all of the
controls on the form searching for the ones
'* whose tag property is set accordingly.
Else it only checks the ones passed by the caller.
'*
'* Control Examples:
'*
'* ListBox
'* -------
'* Visible ........ Yes
'* Enabled ........ Yes
'* Multi Select ... None, Simple, or
Extended
'* Tag ............
Where=tblEmployee.lngDepartmentID,Number;
'*
'* TextBox
'* -------
'* Visible ........ Yes
'* Enabled ........ Yes
'* Tag ............
Where=tblEmployee.dteBirth,Date,>;
'*
'* Range
'* -----
'* Text Box (Begin Date Range: Name must
end with _BeginR)
'* Name ...... txtHireDate_BeginR
'* Visible ... Yes
'* Enabled ... Yes
'* Tag .......
Where=tblEmployee.dteHire,Date;
'*
'* Text Box (End Date Range: Name must end
with _EndR)
'* Name ...... txtHireDate_BeginR
'* Visible ... Yes
'* Enabled ... Yes
'* Tag ....... (not used...function
relies on tag property of BeginDateRange text box)
'*
'* Option Group
'* ------------
'* Visible ... Yes
'* Enabled ... Yes
'* Tag .......
Where=tblEmployee.lngID,Long,=,3;
'*
'* Check Boxes
'* -----------
'* Visible ... Yes
'* Enabled ... Yes
'* Tag .......
Where=tblEmployee.ysnActive,Boolean,=,True;
'*
'* Calling Example:
'*
Docmd.OpenReport "rptYourReport",acViewPreview,,BuildWhere
(Me)
'*
'* or strWhere = BuildWhere(Me)
'*
'-
***********************************************************
**********************************************'
'
Function BuildWhere(frm As Form, _
         ParamArray varCtl() As Variant)
             
'********************************
'* Declaration Specifications *
'********************************

    Dim ctl As Control 'Control currently
being processed
    Dim ctlEndR As Control '2nd control of
Range pair
    
    Dim varItem As Variant 'Items within
multiselect list box
    
    Dim strAnd As String 'And or ""
    Dim strAndOr As String 'Either "And"
or "Or"
    Dim strCtlType As String 'Control Type of
control being processed (also see error handler)
    Dim strFieldName As String 'Table.FieldName
value
    Dim strFieldType As String 'FieldType ' or #
    Dim strFieldValue As String 'Value
    Dim strOperator As String 'Operator (= <> >
< etc)
    Dim strSuffix As String 'Suffix to be
appended at end of a string
    Dim strWhere As String 'Where clause to
be returned to caller
    
    Dim i As Integer 'Working Variable
    
'****************
'* Initialize *
'****************

    On Error GoTo ErrHandler

    strWhere = vbNullString
    strAnd = vbNullString
    
'**************************************
'* Begin loop thru controls on form *
'**************************************

    If (UBound(varCtl) = -1) Then
        For Each ctl In frm.Controls
            GoSub CreateWhere
        Next
    Else
        For i = 0 To UBound(varCtl)
            Set ctl = varCtl(i)
            GoSub CreateWhere
        Next i
    End If

'***********************
'* Save Where Clause *
'***********************

    BuildWhere = strWhere
    
'********************
'* Exit Procedure *
'********************
        
ExitProcedure:

    Exit Function

'*********************************************
'* Create Where Clause for current control *
'*********************************************

CreateWhere:

    strCtlType = BuildWhere_ControlType(frm, ctl)
    
    Select Case strCtlType
            
        Case "Range": GoSub GetTag: GoSub
BuildRange 'strWhere = strWhere & strAnd &
BuildWhere_Range(frm, ctl)
        Case "ListBox": GoSub GetTag: GoSub
BuildListBox 'strWhere = strWhere & strAnd &
BuildWhere_ListBox(frm, ctl)
        Case "TextBox": GoSub GetTag: GoSub
BuildTextBox 'strWhere = strWhere & strAnd &
BuildWhere_TextBox(frm, ctl)
        Case "OptionGroup": GoSub GetTag: GoSub
BuildOptionGroup 'strWhere = strWhere & strAnd &
BuildWhere_OptionGroup(frm, ctl)
        Case "CheckBox": GoSub GetTag: GoSub
BuildCheckBox 'strWhere = strWhere & strAnd &
BuildWhere_CheckBox(frm, ctl)
        Case "ComboBox": GoSub GetTag: GoSub
BuildComboBox
        
    End Select

    If (Len(strWhere) > 0) Then strAnd = " AND "
    
    Return

'##########################################################
################################
'# Retrieve Tag
Items #
'##########################################################
################################

GetTag:

    strFieldName = BuildWhere_GetTag("FieldName", ctl.Tag)
    If (Len(strFieldName) = 0) Then Err.Raise
vbObjectError + 2000, "BuildWhere (GetTag);" &
Err.Source, "Invalid Tag Property (" & ctl.Tag & ")" &
vbCrLf & vbCrLf & "The Tag Property should look like
this:" & vbCrLf & mstrcTagID & "TableName.FieldName" &
mstrcFldSeparator & "FieldType[" & mstrcFldSeparator
& "Operator]" & vbCrLf & vbCrLf & "(where FieldType is
either String, Date, or Number and Operator (optional) is
either =, <>, <, >, <=, >=, Like)"
    strFieldType = BuildWhere_GetTag("FieldType", ctl.Tag)
    
    strOperator = BuildWhere_GetTag("Operator", ctl.Tag)
    strFieldValue = BuildWhere_GetTag("Value", ctl.Tag)
    
    Return
    
'##########################################################
################################
'# Build
Range #
'##########################################################
################################

BuildRange:

    '******************************************************
****
    '* Determine control that represents the End date
range *
    '******************************************************
****
    
    On Error Resume Next
    
    Set ctlEndR = frm(Left$(ctl.Name, Len(ctl.Name) - Len
(mstrcRange_Begin)) & mstrcRange_End)
    
    If (Err.Number = 2465) Then
        On Error GoTo 0
        Err.Raise vbObjectError + 2001, "BuildWhere (" &
strCtlType & ");" & Err.Source, "Invalid Range" & vbCrLf &
vbCrLf & "You have declared a text box that represents the
Begin Range (" & ctl.Name & ") but you did not declare a
control that represents the End Range (" & Left$(ctl.Name,
Len(ctl.Name) - Len(mstrcRange_Begin)) & mstrcRange_End
& ")"
    End If
    
    If (IsNull(ctlEndR)) Then
        On Error GoTo 0
        Err.Raise vbObjectError + 2002, "BuildWhere (" &
strCtlType & ");" & Err.Source, "Invalid Range" & vbCrLf &
vbCrLf & "Your entered a value for the Begin Range but
failed to enter a value for the End Range."
    End If
    
    '*****************
    '* Build Where *
    '*****************
    
    On Error GoTo ErrHandler
                
    If (Len(strFieldValue) = 0) Then strFieldValue = CStr
(ctl.Value)
    
    If (strFieldType = "#") Then 'IFT, then Date Field
        strWhere = strWhere & strAnd & " (" & strFieldName
& " Between #" & strFieldValue & "# AND #" & ctlEndR.Value
& " 23:59:59#) "
    Else
        strWhere = strWhere & strAnd & " (" & strFieldName
& " Between " & strFieldType & strFieldValue &
strFieldType & " AND " & strFieldType & ctlEndR.Value &
strFieldType & ") "
    End If
    
    strAnd = " AND "
                
    Return

'##########################################################
################################
'# List
Box #
'##########################################################
################################

BuildListBox:

'*******************************************
'* Determine Operator (=, >, Like, etc.) *
'*******************************************
    
    strAndOr = vbNullString
    If (Len(strOperator) > 0) Then
        If (strOperator = "<>") Then strAndOr = " AND "
Else strAndOr = " OR "
    End If

    If (Len(strOperator) = 0) Or (strOperator = "=") Then
        strWhere = strWhere & strAnd & " (" & strFieldName
& " In ("
        strSuffix = ", "
    Else
        strWhere = strWhere & strAnd & " (" & strFieldName
& " " & strOperator & " "
        strSuffix = ") " & strAndOr
    End If
                
        
    If (ctl.MultiSelect) Then
        For Each varItem In ctl.ItemsSelected
            strWhere = strWhere & strFieldType & ctl.Column
(ctl.BoundColumn - 1, varItem) & strFieldType & strSuffix
        Next varItem

        strWhere = Mid(strWhere, 1, Len(strWhere) - Len
(strSuffix)) & ")) "

    
    Else
        If (Len(strFieldValue) = 0) Then strFieldValue =
ctl.Column(ctl.BoundColumn - 1)
        strWhere = strWhere & strFieldType & strFieldValue
& strFieldType & strSuffix
    End If
    
    strAnd = " AND "
    
    Return

'##########################################################
################################
'# Text
Box #
'##########################################################
################################

BuildTextBox:

    If (Len(strFieldValue) = 0) Then strFieldValue =
ctl.Value
    
    strWhere = strWhere & strAnd & " (" & strFieldName
& " " & strOperator & " " & strFieldType & strFieldValue &
strFieldType & ") "
    
    strAnd = " AND "
                
    Return

'##########################################################
################################
'# Option
Group #
'##########################################################
################################

BuildOptionGroup:

    If (Len(strFieldValue) = 0) Then strFieldValue =
ctl.Value
    
    strWhere = strWhere & strAnd & " (" & strFieldName
& " " & strOperator & " " & strFieldType & strFieldValue &
strFieldType & ") "
    strAnd = " AND "
                
    Return

'##########################################################
################################
'# Check
Box #
'##########################################################
################################

BuildCheckBox:

    If (Len(strFieldValue) = 0) Then strFieldValue =
ctl.Value
    
    strWhere = strWhere & strAnd & " (" & strFieldName
& " " & strOperator & " " & strFieldType & strFieldValue &
strFieldType & ") "
    strAnd = " AND "
                
    Return

'##########################################################
################################
'# Combo
Box #
'##########################################################
################################

BuildComboBox:

'*******************************************
'* Determine Operator (=, >, Like, etc.) *
'*******************************************
    
    strAndOr = vbNullString
    If (Len(strOperator) > 0) Then
        If (strOperator = "<>") Then strAndOr = " AND "
Else strAndOr = " OR "
    End If

    If (Len(strOperator) = 0) Or (strOperator = "=") Then
        strWhere = strWhere & strAnd & " (" & strFieldName
& " In ("
        strSuffix = ", "
    Else
        strWhere = strWhere & strAnd & " (" & strFieldName
& " " & strOperator & " "
        strSuffix = ") " & strAndOr
    End If
                
    If (Len(strFieldValue) = 0) Then strFieldValue =
ctl.Column(ctl.BoundColumn - 1)
    strWhere = strWhere & strFieldType & strFieldValue &
strFieldType & strSuffix

    strAnd = " AND "
    
    Return

'****************************
'* Error Recovery Section *
'****************************
        
ErrHandler:
    
    Err.Raise Err.Number, "BuildWhere (" & strCtlType
& ");" & Err.Source, Err.Description

End Function

'+*********************************************************
***********************************
'*
'$ Function: BuildWhere_ControlType
'*
'* Author: FancyPrairie
'*
'* Date: April, 1998
'*
'* Purpose: This routine determines if a control
should be included (valid) if it meets the following
conditions:
'*
'* List Boxes
'* 1. Tag Property contains: Where=
'* 2. At least one item selected
'* 3. List Box is enabled
'* 4. List Box is visible
'*
'* Range
'* 1. Tag Property contains: Where=
'* 2. Name of control ends with "_Begin"
'* 3. Value of control is NOT Null
'* 4. Control is enabled
'* 5. Control is visible
'*
'* Text Box
'* 1. Tag Property contains: Where=
'* 2. Value of control is NOT Null
'* 3. Control is enabled
'* 4. Control is visible
'*
'* Combo Boxes
'* 1. Tag Property contains: Where=
'* 2. One item selected
'* 3. Combo Box is enabled
'* 4. Combo Box is visible
'*
'-
***********************************************************
*********************************
'
Function BuildWhere_ControlType(frm As Form, ctl As
Control) As String

'********************************
'* Declaration Specifications *
'********************************

    Dim strTemp As String 'Working variable

'****************
'* Initialize *
'****************
   
    On Error GoTo ErrHandler
    
    BuildWhere_ControlType = vbNullString 'Assume
invalid
    strTemp = Replace(ctl.Tag, " ", vbNullString) 'Strip
out all spaces
    
    If (InStr(strTemp, mstrcTagID) > 0) Then 'If
true, Tag Property contains "Where="
    
        If (ctl.ControlType = acListBox) Then
            
            If (ctl.MultiSelect) And
(ctl.ItemsSelected.Count > 0) And (ctl.Enabled) And
(ctl.Visible) Then BuildWhere_ControlType = "ListBox"
            If (Not ctl.MultiSelect) And (Not IsNull
(ctl.Value)) And (ctl.Enabled) And (ctl.Visible) Then
BuildWhere_ControlType = "ListBox"
               
        ElseIf ((ctl.ControlType = acTextBox) Or
(ctl.ControlType = acComboBox) Or (ctl.ControlType =
acOptionGroup) Or (ctl.ControlType = acCheckBox)) And (Not
IsNull(ctl.Value)) And (Len(ctl.Value) > 0) And
(ctl.Enabled) And (ctl.Visible) Then
            
            If (Right$(ctl.Name, Len(mstrcRange_End)) =
mstrcRange_End) Then GoTo ExitProcedure

            If (Right$(ctl.Name, Len(mstrcRange_Begin)) =
mstrcRange_Begin) Then
                On Error GoTo 0
                If (Not BuildWhere_ValidRange(frm, ctl))
Then Err.Raise vbObjectError +
2002, "BuildWhere_ControlType", "Incomplete Range
Specifications." & vbCrLf & vbCrLf & "You failed to
enter/select a value for " & ctl.Name
                On Error GoTo ErrHandler
                
                BuildWhere_ControlType = "Range"
            
            ElseIf (ctl.ControlType = acTextBox) Then
                BuildWhere_ControlType = "TextBox"
            ElseIf (ctl.ControlType = acComboBox) Then
                BuildWhere_ControlType = "ComboBox"
            ElseIf (ctl.ControlType = acOptionGroup) Then
                BuildWhere_ControlType = "OptionGroup"
            ElseIf (ctl.ControlType = acCheckBox) Then
                BuildWhere_ControlType = "CheckBox"
            End If
        
        End If
    
    End If
    
'********************
'* Exit Procedure *
'********************
        
ExitProcedure:

    Exit Function

'****************************
'* Error Recovery Section *
'****************************
        
ErrHandler:
    
    Err.Raise Err.Number, "BuildWhere_ControlType;" &
Err.Source, Err.Description
    
End Function

'+*********************************************************
***********************************
'*
'$ Function: BuildWhere_ValidRange
'*
'* Author: FancyPrairie
'*
'* Date: April, 1998
'*
'* Purpose: Determines if the values of 2 controls,
that represent ranges, are valid. They are not valid
'* if one or both controls do not contain a
value. For example, the user may have entered a begin
'* date, but failed to enter an end date.
'*
'* Arguments: frm (form)
'* ----------
'* Form that contains the controls to be
processed.
'*
'* avarParControls (variant Parameter Array)
'* -----------------------------------------
'* List of contol(s) to be processed. If
this array is empty, then this routine will
'* retrieve all of the "valid" controls on
the form specified.
'*
'-
***********************************************************
*********************************
'
Function BuildWhere_ValidRange(frm As Form, ctl As
Control) As Boolean

'********************************
'* Declaration Specifications *
'********************************

    Dim ctlEnd As Control
    
'**********************************************************
********
'* Create array with just those text boxes that meet the
specs. *
'**********************************************************
********
    
    On Error GoTo ErrHandler
    
    Set ctlEnd = frm(Left(ctl.Name, Len(ctl.Name) - Len
(mstrcRange_Begin)) & mstrcRange_End)
    
    If (IsNull(ctl)) Or (Len(ctl) = 0) Or (IsNull(ctlEnd))
Or (Len(ctlEnd) = 0) Then
        BuildWhere_ValidRange = False
    Else
        BuildWhere_ValidRange = True
    End If
    
'********************
'* Exit Procedure *
'********************
        
ExitProcedure:

    Exit Function

'****************************
'* Error Recovery Section *
'****************************
        
ErrHandler:
    
    Err.Raise Err.Number, "BuildWhere_ValidRange;" &
Err.Source, Err.Description
    
End Function

'+*********************************************************
***********************************
'*
'$ Function: BuildWhere_GetTag
'*
'* Author: FancyPrairie
'*
'* Date: April, 1998
'*
'* Purpose: This routine will return the value for a
given Tag Item. The caller specifies
'* which item they want returned. Possible
items are:
'* 1. FieldName
'* 2. FieldType
'* 3. Operator
'* 4. Value
'*
'* Note that this routine assumes the Tag
Property contains an item that is formatted as:
'* Where=TableName.TableField,FieldType
[,Operator,Value].
'*
'* Arguments: strFunction (string)
'* --------------------
'* Can be one of: FieldName, FieldType,
Operator, Value
'*
'* strTag (string)
'* ---------------
'* String that contains an item that is
formatted as:
'* Where=TableName.TableField,FieldType
[,Operator,Value].
'*
'-
***********************************************************
*********************************
'
Function BuildWhere_GetTag(strFunction As String, strTag
As String) As String

'********************************
'* Declaration Specifications *
'********************************

    Dim i As Integer 'Working variable
    Dim j As Integer 'Working variable
    Dim k As Integer 'Working variable
    
    Dim strTemp As String 'Working variable
    Dim var As Variant 'Working variable
        
    On Error GoTo ErrHandler
    
'**********************************************************
****
'* Loop to find "Where=" Tag within Controls Tag
Property *
'* When the "Where=" is found, then parse out the
item *
'* the caller requested (i.e.
FieldName,FieldType,Operator) *
'**********************************************************
****

    var = Split(strTag, mstrcTagSeparator)

    BuildWhere_GetTag = vbNullString
    
    For i = 0 To UBound(var)
        
        strTemp = Replace(CStr(var(i)), " ", vbNullString)
        
        j = InStr(1, strTemp, mstrcTagID) 'Find "Where="
        
        If (j = 1) Then 'If true,
found "Where="
            
            strTemp = CStr(var(i))
            j = InStr(1, strTemp, "=")
            
            var = Split(Mid(strTemp, j + 1),
mstrcFldSeparator)
            
            '***************
            '* FieldName *
            '***************
            
            If (strFunction = "FieldName") Then
                BuildWhere_GetTag = Trim(CStr(var(0)))
            
            '***************
            '* FieldType *
            '***************
            
            ElseIf (strFunction = "FieldType") Then
                If (UBound(var) < 1) Then
                    BuildWhere_GetTag = vbNullString
                Else
                    Select Case Trim(CStr(var(1)))
                        Case "String": BuildWhere_GetTag =
mstrcStringSymbol
                        Case "Date": BuildWhere_GetTag =
mstrcDateSymbol
                        Case Else: BuildWhere_GetTag =
vbNullString
                    End Select
                End If

            '**************
            '* Operator *
            '**************

            ElseIf (strFunction = "Operator") Then
                If (UBound(var) < 2) Then
BuildWhere_GetTag = "=" Else BuildWhere_GetTag = Trim(CStr
(var(2)))

            '***********
            '* Value *
            '***********

            ElseIf (strFunction = "Value") Then
                If (UBound(var) < 3) Then
                    BuildWhere_GetTag = vbNullString
                Else
                    BuildWhere_GetTag = Trim(CStr(var(3)))
                End If
                
            End If
            
            Exit Function
            
        End If
    
    Next i

'********************
'* Exit Procedure *
'********************

ExitProcedure:

    Exit Function
    
'********************
'* Error Recovery *
'********************

ErrHandler:

    Err.Raise Err.Number, "BuildWhere_GetTag;" &
Err.Source, Err.Description
    
End Function

>-----Original Message-----
>I've set up a database and form in Access and have a
multi-select list box
>(listing product types). I want the field to include all
selected products
>in a list separated by commas but right now, after I
select multiple
>products, the field is blank.
>.
>

Relevant Pages

  • Re: CreateEventProc error
    ... Private Sub BuildDisplayForm(strPath As String, ... Dim qdf As QueryDef, qdfControls As QueryDef ... Dim ctl As Control, ctlLabel As Control, ctlParent As Control ... Dim strFilter As String, strSuffix As String, strParentName As String, ...
    (microsoft.public.access.forms)
  • Re: All Menu Navigation
    ... i based the implementation on sample code from http://www.asp.net/CSSAdapters/Menu.aspx, which shows how to create decent HTML for a Menu control bound to a SiteMapDataSource. ... public void RenderBeginTag(HtmlTextWriter writer, string cssClass) ... static public void RemoveProblemTypes ...
    (microsoft.public.dotnet.framework.aspnet)
  • Re: DataGrid not showing programmatic changes
    ... There's another data grid control that will connect, ... DAO then select the DBGrid32.ocx. ... > Public Property Let Connection(ByVal sConn As String) ...
    (microsoft.public.vb.general.discussion)
  • RE: Preventing duplicate entries
    ... Naming the control by the same name as the field to which it's bound (the ... following the naming convention of a three-character prefix that identifies ... Null to a string variable. ... Set rsc = Me.RecordsetClone ...
    (microsoft.public.access.forms)
  • basic_string::npos
    ... string is not found. ... size_type max_sizeconst; ... the object can control. ... -1 is assuredly larger than the length of the longest sequence ...
    (alt.comp.lang.learn.c-cpp)