How do I make this code send the same message to multiple groups?

[TracyD]

Here is the code. I want to have it send the same message to multiple groups. Can someone please help?

Private Sub Application_Reminder(ByVal Item As Object)


Dim CF As Folder
Set CF = Application.Session.GetDefaultFolder(olFolderContacts)


Dim DLI As DistListItem
Set DLI = CF.Items("GDL Group 1")

Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
If Item.Categories <> "Recurring GDL Recert Email" Then Exit Sub
MItem.To = DLI
MItem.Subject = Item.Subject
MItem.Body = Item.Body
MItem.Send
Set MItem = Nothing


End Sub

[gmayor]

Based on your original code, which I assume does what you require (though I suspect 'Recert' may be a typo)? The following should send the message to the listed groups (strGroups).

If you don't want the recipients to see who else has received the message change Type = 1 to Type = 3


Private Sub Application_Reminder(ByVal Item As Object)

Const strGroups As String = "GDL Group 1|GDL Group 2|GDL Group 3" 'the names of the groups
Dim vGroups As Variant
Dim DLI As DistListItem
Dim CF As Folder
Dim i As Long
Dim MItem As MailItem

Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
vGroups = Split(strGroups, "|")
Set MItem = Application.CreateItem(olMailItem)
If Item.MessageClass <> "IPM.Appointment" Then GoTo lbl_Exit
If Item.Categories <> "Recurring GDL Recert Email" Then GoTo lbl_Exit 'Check your spelling 'Recert'?
For i = LBound(vGroups) To UBound(vGroups)
Set DLI = CF.Items(vGroups(i))
MItem.Recipients.Add(DLI).Type = 1
Next i
MItem.Subject = Item.Subject
MItem.Body = Item.Body
'MItem.Display
MItem.Send
lbl_Exit:
Set MItem = Nothing
Set CF = Nothing
Set DLI = Nothing
Exit Sub
End Sub

[TracyD]

gmayor:

Again, thank you very much! I will give it a whirl when I get back to the office. I contacted your site with another question and will repeat an excerpt of it here. Will your additions send the message to each group as a separate message? I need each group to see only the recipients of their group. Like it is a dedicated message to their group in order respect the privacy of each group's personnel business.

On a side note, "Recurring GDL Recert Email" is the name of a outlook category for appointments. So its fine as a title that only I see in my outlook account. This message initiate and runs with a certain appointment each Monday. I was trying to use as much outlook functionality as possible so I can hand it to the manager to run without dealing with code.


Thanks Again!
TracyD

[TracyD]

I keep forgetting things to ask regarding this program. :rofl:

I am also trying to figure out how to get the message to keep the formatting in the body. The final manager of this will want to put fancy formatted signatures in the body. Right now, it strips the format down to the base level fonts.

Many, many thanks!
TracyD

[gmayor]

The code as written creates one message sent to all the recipients. If you use the BCC option (Type = 3) no-one will see anyone else's messages. The recipient will only see the message sent to him/her and will not see who else it was sent to. If you want separate messages you will have to perform the complete message creation in the loop.

If you want formatting and the default signature included, then you may need the following which includes a covering message, the default signature and the original message.


Private Sub Application_Reminder(ByVal Item As Object)

Const strGroups As String = "GDL Group 1|GDL Group 2|GDL Group 3" 'the names of the groups
Dim vGroups As Variant
Dim DLI As DistListItem
Dim CF As Folder
Dim i As Long
Dim MItem As MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object

Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
vGroups = Split(strGroups, "|")
If Item.MessageClass <> "IPM.Appointment" Then GoTo lbl_Exit
If Item.Categories <> "Recurring GDL Recert Email" Then GoTo lbl_Exit 'Check your spelling 'Recert'?

For i = LBound(vGroups) To UBound(vGroups)
Set MItem = Item.Reply
Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
Set DLI = CF.Items(vGroups(i))
With MItem
.Recipients.Add(DLI).Type = 1
.Subject = Item.Subject
.BodyFormat = olFormatHTML
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Reminder!" 'The reminder text
'.Send
End With
Next i

lbl_Exit:
Set MItem = Nothing
Set CF = Nothing
Set DLI = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[TracyD]

GMayor:

Thank you so much! This worked great!!! I did have to comment out a few lines as follows to get it to use the body from the appointment body. As written, it still does not want to pick up the fancy formatting of the signature in the appointment body. Do you have any ideas? I also came up with a new question. How would I tweak it to keep running even though some groups have no email addresses in them? In this business application, it will happen from time to time. Thanks again! This is great! :beerchug:


Private Sub Application_Reminder(ByVal Item As Object)

Const strGroups As String = "GDL Group 1|GDL Group 2|GDL Group 3" 'the names of the groups
Dim vGroups As Variant
Dim DLI As DistListItem
Dim CF As Folder
Dim i As Long
Dim MItem As MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object

Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
vGroups = Split(strGroups, "|")
If Item.MessageClass <> "IPM.Appointment" Then GoTo lbl_Exit
If Item.Categories <> "Recurring GDL Recert Email" Then GoTo lbl_Exit 'Check your spelling 'Recert'?

For i = LBound(vGroups) To UBound(vGroups)
Set MItem = Application.CreateItem(olMailItem)
Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
Set DLI = CF.Items(vGroups(i))
With MItem
.Recipients.Add(DLI).Type = 1
.Subject = Item.Subject
.BodyFormat = olFormatHTML
.Display
.Body = Item.Body
'Set olInsp = .GetInspector
'Set wdDoc = olInsp.WordEditor
'Set oRng = wdDoc.Range(0, 0)
'oRng.Text = "Reminder!" 'The reminder text
.Send
End With
Next i

lbl_Exit:
Set MItem = Nothing
Set CF = Nothing
Set DLI = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[TracyD]

I copied that out of word. Not sure why it doesn't keep the indention.

[gmayor]

Change

.Body = Item.Body
to

.HTMLBody = Item.HTMLBody

If your groups might have no members, test for the member count before creating the message.
when posting code use the '#' symbol on the message toolbar to add CODE tags before sending your message to keep the indentations as below.


Private Sub Application_Reminder(ByVal Item As Object)

Const strGroups As String = "GDL Group 1|GDL Group 2|GDL Group 3" 'the names of the groups
Dim vGroups As Variant
Dim DLI As DistListItem
Dim CF As Folder
Dim i As Long
Dim MItem As MailItem

Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
vGroups = Split(strGroups, "|")
If Item.MessageClass <> "IPM.Appointment" Then GoTo lbl_Exit
If Item.Categories <> "Recurring GDL Recert Email" Then GoTo lbl_Exit 'Check your spelling 'Recert'?

For i = LBound(vGroups) To UBound(vGroups)
Set MItem = Application.CreateItem(olMailItem)
Set CF = Application.Session.GetDefaultFolder(olFolderContacts)
Set DLI = CF.Items(vGroups(i))
If DLI.MemberCount > 0 Then
With MItem
.Recipients.Add(DLI).Type = 1
.Subject = Item.Subject
.BodyFormat = olFormatHTML
.HTMLBody = Item.HTMLBody
.Display 'remove after testing
'.Send 'remove the apostrophe after testing
End With
End If
Next i

lbl_Exit:
Set MItem = Nothing
Set CF = Nothing
Set DLI = Nothing
Exit Sub
End Sub