Emailing Groups through Multiple Selections with List Box

[Imagemo]

Hello...

So recently I set up a combo box that could email out items to a group. The client wants it changed so that she can select multiple groups and email them at the same time. Is there an easy way of going from a combo box to a list box without having to change too much of the code. The code that I used with the combo box is below:

Private Sub btnSend_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim rs As DAO.Recordset
Dim ToRecipient As String
  
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.CreateItem(olMailItem)


If Me.lstGroup.Column(1) = "Group A" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryA")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group B" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryB")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group C" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryC")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group D" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryD")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group E" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryE")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group F" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryF")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
If Me.lstGroup.Column(1) = "Group G" Then
Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryG")
Do While rs.EOF = False
    OlMail.Recipients.Add rs!Email
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing


End If
End If
End If
End If
End If
End If
End If


OlMail.Subject = " "
OlMail.Display




End Sub

[Gicu]

You just need to adapt your existing code to include a loop through the ItemsSelected collection of the listbox: https://docs.microsoft.com/en-us/off....itemsselected

Cheers,
Vlad

[June7]

Have to loop through listbox SelectedItems to reference each selected item. An example of looping code in http://allenbrowne.com/ser-50.html

Inside your loop you would have code to open and loop recordset using the SelectedItem as filter criteria.

Your code would be easier to read if you used indentation.

[Imagemo]

So I set up a "For Each" Loop around my previous code...and it does open Outlook, but it seems to be sending it only to the same group several times. I'm sure it's because I'm not properly coding the loop, but I can't figure out where.

Private Sub btnSend_Click()

Dim OlApp As Object
Dim OlMail As Object
Dim rs As DAO.Recordset
Dim ToRecipient As String
Dim varItem As Variant
  
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.CreateItem(olMailItem)


For Each varItem In Me.lstGroup.ItemsSelected
    If Me.lstGroup.Column(1) = "Group A" Then
        Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryA")
        Do While rs.EOF = False
        OlMail.Recipients.Add rs!Email
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing
    Else
        If Me.lstGroup.Column(1) = "Group B" Then
        Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryB")
        Do While rs.EOF = False
        OlMail.Recipients.Add rs!Email
        rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
        Else
            If Me.lstGroup.Column(1) = "Group C" Then
            Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryC")
            Do While rs.EOF = False
            OlMail.Recipients.Add rs!Email
            rs.MoveNext
            Loop
            rs.Close
            Set rs = Nothing
            Else
                If Me.lstGroup.Column(1) = "Group D" Then
                Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryD")
                Do While rs.EOF = False
                OlMail.Recipients.Add rs!Email
                rs.MoveNext
                Loop
                rs.Close
                Set rs = Nothing
                Else
                    If Me.lstGroup.Column(1) = "Group E" Then
                    Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryE")
                    Do While rs.EOF = False
                    OlMail.Recipients.Add rs!Email
                    rs.MoveNext
                    Loop
                    rs.Close
                    Set rs = Nothing
                    Else
                        If Me.lstGroup.Column(1) = "Group F" Then
                        Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryF")
                        Do While rs.EOF = False
                        OlMail.Recipients.Add rs!Email
                        rs.MoveNext
                        Loop
                        rs.Close
                        Set rs = Nothing
                        Else
                            If Me.lstGroup.Column(1) = "Group G" Then
                            Set rs = CurrentDb.OpenRecordset("SELECT Email FROM qryG")
                            Do While rs.EOF = False
                            OlMail.Recipients.Add rs!Email
                            rs.MoveNext
                            Loop
                            rs.Close
                            Set rs = Nothing
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
Next varItem


OlMail.Subject = " "
OlMail.Display




End Sub

[June7]

This code now looks very familiar. Suggested much simpler structure in your other thread. Modified to use listbox:

Dim OlApp As Object
Dim OlMail As Object
Dim rs As DAO.Recordset
Dim varItem As Variant
  
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.CreateItem(olMailItem)
With Me.lstGroup
    For Each varItem In .ItemsSelected
        If Not IsNull(varItem) Then
            Set rs = CurrentDb.OpenRecordset("SELECT Email FROM tableORquery WHERE Group = '" & .ItemData(varItem) & "'")
            Do While rs.EOF = False
                OlMail.Recipients.Add rs!Email
                rs.MoveNext
            Loop
            rs.Close
        End If
    Next
End With
OlMail.Subject = " "
OlMail.Display
Set rs = Nothing