Multi-Selection Code review

[thorn2fish]

My objective was to use a form to execute a db query object filtered by a
multi-select listbox control. While I've been an application developer for a
long time, I haven't done much VBA (or VB). The the code below (from the
button on click event) gets it done, but did I make it harder than I had too
(with the understanding that I wanted to leave the SQL in a query object)?

I'd give credit to those that gave me input (many of which were fom this
forum), but they are numerous at this point. Thanks to all!

' Read the SQL from an existing Query Object and insert
' parameter values into the IN clause of the SQL from a
' multi-value (select) listbox forms object.
' It does this by locating the IN clause in the SQL and replaces
' current parameter list with a new list.
' It requires a minimal IN criteria list be initially coded in
' the query.
Private Sub Command3_Click()
Dim sqlStr As String ' SQL from query object
Dim sqlNew As String ' New SQL statement being built
Dim qryName As String ' name of the query object
Dim tblCol As String ' db table column name being searched
Dim selPos As Integer ' index into SQL statement
Dim frm As Form ' pointer to current (calling) form
Dim frmName As String ' name of the current (calling) form
Dim ctl As Control ' multi-select listbox control
Dim varItem As Variant ' used to parse the selected listbox entries

Set frm = Screen.ActiveForm ' Save pointer to calling form
frmName = frm.Name ' Save the name of the calling form

' !!!! Change following statements when duplicating !!!!
Set ctl = frm!System ' Multi-Value listbox control
qryName = "Query2" ' Query to be executed by this form
tblCol = "System" ' DB Table filter column

If ctl.ItemsSelected.Count = 0 Then ' kick out an error if no listbox
entries were selected
MsgBox "No entries selected from list." & Chr(10) & Chr(10) & _
"At least one entry must be selected." & Chr(10) & _
"Select multiple entries by holding the CTL key.", vbExclamation
GoTo getout
End If

DoCmd.Close acQuery, qryName, acSaveYes ' Close the db query object if
it is open

sqlStr = CurrentDb.QueryDefs(qryName).SQL ' save local copy of SQL to be
modified
sqlStr = Replace(sqlStr, Chr(10), " ") ' Strip out the LF Access sticks
into the text.

' Split current SQL statement at the "(" on the IN list
' Find the start of the selection IN list within the current SQL's WHERE
clause
selPos = InStr(sqlStr, " WHERE")
If selPos > 0 Then
selPos = InStr(selPos, sqlStr, tblCol) ' Find filter column name in
the where clause
If selPos > 0 Then ' Then its associated "IN"
clause
selPos = selPos + Len(selFld) + InStr(Mid(sqlStr, selPos +
Len(selFld), 5), "IN")
If selPos > 0 Then
selPos = InStr(selPos, sqlStr, "(") ' and last the start of the
selection criteria
End If
End If
End If

If selPos = 0 Then ' kick out an error if the filter criteria cannot be
found in the SQL
MsgBox "Query execution error." & Chr(10) & Chr(10) & _
"No WHERE or IN list in Query" & Chr(10) & _
"or VBA code mis-match!", vbExclamation
GoTo getout
End If

sqlNew = Left(sqlStr, InStr(selPos, sqlStr, "(")) ' Copy SQL statement up
to the " IN " statement

For Each varItem In ctl.ItemsSelected ' load the selected listbox control
entries into the query
sqlNew = sqlNew & """"
sqlNew = sqlNew & ctl.ItemData(varItem)
sqlNew = sqlNew & ""","
Next varItem

' Concatenate the remainder of original SQL Statement with the new statement
' backing up over the last "," in the new statement
sqlNew = Left(sqlNew, Len(sqlNew) - 1) & Mid(sqlStr, InStr(selPos, sqlStr,
")"))

CurrentDb.QueryDefs(qryName).SQL = sqlNew ' Load new SQL statement back to
db Query Object
DoCmd.OpenQuery qryName ' Execute Query Object
DoCmd.Close acForm, frmName ' Close the calling form
getout:
End Sub

 

[Klatuu]

I ususally do this using two stored queries. One that will remain pristeen
and not be modified. That way, I know for sure what it is going to contain
when I use it. The other I use for the execution after I have rebuild the
criteria. One of the advantages here is that it requires preconceived IN
clause. It allows you to use whatever you want. I create the query with no
real criteria. I do add a Where Clause like this:
WHERE 1 = 1

This is to allow me to use the Replace function once I have the criteria
string built. Below is a function I use for building a criteria string for
a multi select list box.

Private Sub Command3_Click()
Dim strWhere As String
Dim strSQL As String
Dim qdfs As QueryDefs

Set qdfs = Currentdb.QueryDefs

'Build the criteria string
strWhere = BuildWhereCondition(Me!System.Name)
'Get the base query sql - In my naming conventions, queries beginning with
zz are base queries I use for just such activities
strSQL = qdfs("zzQuery2")
'Modify the string with the criteris
if Len(strWhere) > 0 Then
strSQL = Replace(strlSQL, "1 = 1", strWhere)
End If
'Put it in the query to execute
qdfs("Query2").SQL = strSQL
End Sub

DoCmd.OpenQuery "Query2" ' Execute Query Object
DoCmd.Close acForm, Screen.ActiveForm.Name ' Close the
calling form

Set qdfs = Nothing

End Sub

*******************************************************************************

Private Function BuildWhereCondition(strControl As String) As String
'Set up the WhereCondition Argument for the reports
Dim varItem As Variant
Dim strWhere As String
Dim ctl As Control

Set ctl = Me.Controls(strControl)

Select Case ctl.ItemsSelected.Count
Case 0 'Include All
strWhere = ""
Case 1 'Only One Selected
strWhere = "= '" & _
ctl.ItemData(ctl.ItemsSelected(0)) & "'"
Case Else 'Multiple Selection
strWhere = " IN ("

With ctl
For Each varItem In .ItemsSelected
strWhere = strWhere & "'" & .ItemData(varItem) & "', "
Next varItem
End With
strWhere = Left(strWhere, Len(strWhere) - 2) & ")"
End Select

BuildWhereCondition = strWhere

End Function

*******************************************************************************

 

[thorn2fish]

I appreciate your response very much. Since I'm realitvely new to VBA, I
really needed a sanity check to make sure I wasn't making a mountain out of a
mole hill. I'm glad to see that the basic concept is something that has
already been tested and found functional. I can also see the added
flexibility your method provides.

Again I hope others can benefit from this exchange. FYI, I'll wait to post
this as answered for a little to give others have a little more time to see
it and respond.
Thanks again!