Article ID: 121356
Article Last Modified on 11/6/2000
Option Explicit
Type MultiSelectArray_TYPE
Selected As String ' Holds "X" or "" indicating selection
Display As Variant ' The value to display in the list box
' row. Example: John Smith
Value As Variant ' The value to store for the row
' selection. Example: 535-86-9328 (John's
' SSN)
End Type
Dim MultiSelectArray() As MultiSelectArray_TYPE
Dim MultiSelectRows
' Flag indicating if the list is being updated (new selection)
' or being filled.
Global UpdateMultiSelect
Function MultiSelect (fld As Control, id As Long, Row As _
Long, Col As Long, Code As Integer)
'*******************************************************
' CALLED FROM: The RowSourceType property of a list box.
' EXAMPLE:
' RowSourceType: MultiSelect
'*******************************************************
Dim RetVal: RetVal = Null
Select Case Code
Case LB_INITIALIZE
' Is the list being updated by a new selection?
If UpdateMultiSelect Then
' If so, ignore refilling the list.
UpdateMultiSelect = False
Else
' Otherwise, fill the MultiSelect array.
MultiSelectRows = MultiSelectFillArray()
End If
RetVal = MultiSelectRows
Case LB_OPEN
RetVal = Timer ' Unique ID number for control.
Case LB_GETROWCOUNT
' Return the number of rows in the MultiSelect array.
RetVal = UBound(MultiSelectArray) + 1
Case LB_GETCOLUMNCOUNT
' Return the number of columns to display.
RetVal = 2
Case LB_GETCOLUMNWIDTH
RetVal = -1 ' Use the default width.
Case LB_GETVALUE
Select Case Col
Case 0 ' Selected
RetVal = MultiSelectArray(Row).Selected
Case 1 ' Display
RetVal = MultiSelectArray(Row).Display
End Select
Case LB_END ' End
End Select
MultiSelect = RetVal
End Function
Function MultiSelectUpdate (C As Control)
'********************************************************
' CALLED FROM: The AfterUpdate property of the list box.
' EXAMPLE:
' AfterUpdate: =MultiSelectUpdate([<YourListBoxName>])
'********************************************************
' Update the MultiSelect array selection by toggling
' the "X" in the selected row.
Select Case MultiSelectArray(C).Selected
Case ""
MultiSelectArray(C).Selected = "X"
Case "X"
MultiSelectArray(C).Selected = ""
End Select
' Set the flag indicating an update.
UpdateMultiSelect = True
' Requery the list.
C.Requery
End Function
Function MultiSelectFillArray ()
'**********************************************************
' PURPOSE: Fills the MultiSelect array with a list of
' names from the Employees table.
' CALLED FROM: The MultiSelect() function's initialization
' code to fill the list box array with values.
'**********************************************************
Dim DB As Database
Dim RS As Recordset
Dim i As Integer
Dim RecordCount As Integer
Set DB = DBEngine.Workspaces(0).Databases(0)
Set RS = DB.OpenRecordset("Employees", DB_OPEN_SNAPSHOT)
' Get record count.
RS.MoveLast
RecordCount = RS.RecordCount
RS.MoveFirst
' Resize the MultiSelect array to the number of Employee
' records.
ReDim MultiSelectArray(0 To RecordCount - 1)
' Fill the MultiSelect array by setting:
' Selected to "" (clearing "X").
' Display to [First Name] space [Last Name].
' Value to [Employee ID].
For i = 0 To RecordCount - 1
MultiSelectArray(i).Selected = ""
MultiSelectArray(i).Display = RS![First Name] & " " _
& RS![Last Name]
MultiSelectArray(i).Value = RS![Employee ID]
RS.MoveNext
Next i
' Return the number of rows in the array (RecordCount).
MultiSelectFillArray = RecordCount
End Function
Function MultiSelectFillArray ()
'**********************************************************
' PURPOSE: Fills the MultiSelect array with a list of
' field names from the Employees table.
' CALLED FROM: The MultiSelect() function's initialization
' code to fill the list box array with values.
'**********************************************************
Dim DB As Database
Dim RS As Recordset
Dim i As Integer
Set DB = DBEngine.Workspaces(0).Databases(0)
Set RS = DB.OpenRecordset("Employees", DB_OPEN_SNAPSHOT)
' Resize the MultiSelect array to the number of Employee
' fields.
ReDim MultiSelectArray(0 To RS.Fields.Count - 1)
' Fill the MultiSelect array by setting:
' Selected to "" (clearing "X").
' Display to the name of the field.
' Value to the name of the field.
For i = 0 To RS.Fields.Count - 1
MultiSelectArray(i).Selected = ""
MultiSelectArray(i).Display = RS(i).Name
MultiSelectArray(i).Value = RS(i).Name
Next i
' Return the number of rows in the array (the number of
' fields).
MultiSelectFillArray = RS.Fields.Count
End Function
Name: EmployeeFields
ControlSource: <blank>
RowSourceType: MultiSelect
RowSource: <blank>
ColumnCount: 2
ColumnWidths: 0.15 in.
BoundColumn: 0
Width: 1.6 in
Height: 1.5 in
AfterUpdate: =MultiSelectUpdate([EmployeeFields])
Function MultiSelectSemicolonList ()
Dim i
Dim Result
Result = ""
For i = 0 To UBound(MultiSelectArray)
If MultiSelectArray(i).Selected = "X" Then
Result = Result & MultiSelectArray(i).Display & "; "
End If
Next i
' Remove the last semicolon.
If Result <> "" Then Result = Left(Result, Len(Result) - 1)
MultiSelectSemicolonList = Result
End Function
Additional query words: multiselection
Keywords: kbhowto kbusage KB121356