Need to be able to select multiple options for each line of form

M

melissad

I am trying to build a contact database linking multiple tables (some with
repeating information). I would like to select on each contacts page the
groups they belong to. Like the categories listing in Outlook. This way I can
delete duplicate information. Access won't let me do things that are specific
to each line , they want the information for the whole table. Can anyone
help????
 
D

Dave M

You have or need a table of contacts, a table of groups (in my app they're
'categories') and a joining table that lists the groups that each contact
belongs to, right? With that setup, you can place a multi-select list box on
the contact form and use code like this to update the display and maintain
the list of contact's groups.

In this example, the form also displays a string that lists the category
abbreviations; this isn't necessary for the list to work; the users have
another purpose for it.

Private Sub Form_Current()

' this procedure selects the appropriate categories in the list box when
the form is refreshed

Dim intCurrentRow As Integer
Dim rstContactCats As DAO.Recordset
Dim strSQL As String
Dim bolHasCats As Boolean

strCategories = vbNullString
If Not IsNull(Me![ID]) Then ' there is a contact whose categories we
want to describe
strSQL = "SELECT [Contact Categories].Category" _
& " FROM Categories INNER JOIN [Contact Categories] ON
Categories.[Category ID] = [Contact Categories].Category" _
& " WHERE ((([Contact Categories].Contact) = " & Me![ID] &
"))" _
& " ORDER BY Categories.Abbreviation;"

Set rstContactCats = CurrentDb.OpenRecordset(strSQL)
With rstContactCats
If Not .EOF Then ' this contact does have at least one
category assigned
.MoveFirst
End If
For intCurrentRow = 0 To Me![lstCategories].ListCount - 1
If Not .EOF Then ' show categories as selected
If CLng(Me![lstCategories].ItemData(intCurrentRow)) =
![Category] Then
Me![lstCategories].Selected(intCurrentRow) = True
strCategories = strCategories &
Me![lstCategories].Column(1, intCurrentRow) & ", "
' If Not .EOF Then
.MoveNext
Else
Me![lstCategories].Selected(intCurrentRow) = False
End If
Else ' show no selections
Me![lstCategories].Selected(intCurrentRow) = False
End If
Next intCurrentRow
End With
Me![txtCategories] = strCategories
Else
Me![txtCategories] = vbNullString
End If
Me![Category] = Me![txtCategories]

End Sub


Private Sub lstCategories_Exit(Cancel As Integer)

' this procedure saves any changes to the selected categories, replacing
the contact's old ones with current ones

On Error GoTo Err_lstCategories_Exit
Dim intCurrentRow As Integer
Dim rstContactCats As DAO.Recordset
Dim strSQL As String, strCats As String
Dim bolHasCats As Boolean
Dim varItem As Variant

strCats = vbNullString
For Each varItem In Me![lstCategories].ItemsSelected
strCats = strCats & Me![lstCategories].Column(1, varItem) & ", "
Next varItem
If strCats <> Me![txtCategories] Then ' list of categories has been
changed
DoCmd.SetWarnings False
' Delete existing categories for this contact
DoCmd.RunSQL "DELETE * FROM [Contact Categories] WHERE [Contact] = "
& Me![ID]
'and create new ones
For Each varItem In Me![lstCategories].ItemsSelected
DoCmd.RunSQL "INSERT INTO [Contact Categories] ( Contact,
Category, [Date Assigned] )" _
& " SELECT " & Me![ID] & " AS Contact, " &
Me![lstCategories].ItemData(varItem) & " AS Category, Date() AS Assigned;"
Next varItem
DoCmd.SetWarnings True
Me![txtCategories] = strCats
Me![Category] = Me![txtCategories]
End If

Exit_lstCategories_Exit:
DoCmd.SetWarnings True
Exit Sub

Err_lstCategories_Exit:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_lstCategories_Exit

End Sub
 
Top