VBA Outlook Macro to send Bulk mail to distribution lists one by one

I saw something like this before but couldn't remember where, so I wrote it up from memory and scrounging the net. I am using Office 2010 VBA.

This macro presents a user form that allows the user to select a message from the Drafts folder, and then send copies of the message individually to the addresses on multiple Distribution Lists one at a time. Duplicate addresses are automatically deleted and the messages are sent with a delay at 10 second intervals.

This allows for a more personal form of sending emails, and avoids the limitatons that some servers have on sending bulk mail. It also means that the recipients receive a letter only to them with no CC or BCC. This makes it easier to land in the inbox instead of the Junk mail box.

I tried to find a way to look up more contact information, such as name, title and so forth in order to have a more personalized mail merge sort of thing, but I couldn't figure that out. Maybe someone can post improvements on this.

First make a user form called "BulkSend" that looks something like this:
Attachment 93779
(Mine is taller)

It has the following controls:

• Combo box "Drafts"
• Listbox "ContactList"
• Listbox "Recipients"
• Button "CancelButton"
• Button "OKButton"
• Label "TotalRecipients"
• and a few more labels whose names are not important.

Then make a simple macro to show the user form:
Sub Send_Update()
BulkSend.Show 1
End Sub

In the form, add the following subroutines:

Private Sub CancelButton_Click()
End
End Sub

Private Sub ContactList_Change()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myDistList As Outlook.DistListItem
Dim myFolderItems As Outlook.Items
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim c As Integer
Dim e As String
Dim dup As Boolean
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myFolderItems = myFolder.Items
i = myFolderItems.Count

'Fill the Recipients List with the selected email addresses
Recipients.Clear
If ContactList.ListCount = 0 Then Exit Sub
For c = 0 To ContactList.ListCount - 1
If ContactList.Selected(c) Then
'Locate the selected Distribution List
For x = 1 To i
If TypeName(myFolderItems.Item(x)) = "DistListItem" Then
Set myDistList = myFolderItems.Item(x)
If ContactList.List(c) = myDistList.DLName Then
'Found the list, now add the members
For y = 1 To myDistList.MemberCount
e = myDistList.GetMember(y).Address
If e > "" Then
'Check for duplicates
dup = False
For Each Item In Recipients.List
If Item = e Then
dup = True
Exit For
End If
Next
If dup = False Then Recipients.AddItem e
End If
Next y
End If
End If
Next x
End If
Next c
TotalRecipients.Caption = "Recipients:" & Str(Recipients.ListCount)

End Sub

Private Sub OKButton_Click()

OKButton.Enabled = False
If Recipients.ListCount = 0 Then
MsgBox "This macro sends individual emails to recipients on the selected distribution lists."
End
End If

'Locate the selected draft
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myFolderItems As Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)
Set myFolderItems = myFolder.Items
Dim oMailItem As Outlook.MailItem
Dim SelectedMail As Outlook.MailItem
Dim CopyOf As Outlook.MailItem
Dim mFound As Boolean
Dim ptr As Integer
Dim t As Long
mFound = False
For Each oMailItem In myFolderItems
If oMailItem.Subject = Drafts.Text Then
Set SelectedMail = oMailItem
mFound = True
Exit For
End If
Next
If Not mFound Then
MsgBox "The draft has been deleted!"
End
End If
For ptr = 0 To Recipients.ListCount - 1
Set CopyOf = SelectedMail.Copy
CopyOf.Recipients.Add Recipients.List(ptr)
BulkSend.Caption = "Queing " & CopyOf.Subject & " to " & Recipients.List(ptr)
t = t + 10
CopyOf.DeferredDeliveryTime = DateAdd("s", t, Now)
CopyOf.Send
DoEvents
Next
MsgBox "Finished queing " & Recipients.ListCount & " emails. They will be sent at 10 second intervals."
End
End Sub

Private Sub UserForm_Initialize()

'Load the distribution lists in Contacts
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myDistList As Outlook.DistListItem
Dim myFolderItems As Outlook.Items
Dim x As Integer
Dim i As Integer
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myFolderItems = myFolder.Items

i = myFolderItems.Count
If i = 0 Then
MsgBox "In order to use this macro, make Distribution Lists and place them in the 'Contacts' folder."
End
End If
ContactList.Clear
For x = 1 To i
If TypeName(myFolderItems.Item(x)) = "DistListItem" Then
Set myDistList = myFolderItems.Item(x)
ContactList.AddItem myDistList.DLName
End If
Next x

'Load the Drafts from the drafts folder
Drafts.Clear
Dim oMailItem As Outlook.MailItem
Dim sSubject As String
Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)
Set myFolderItems = myFolder.Items
If myFolderItems.Count = 0 Then
MsgBox "In order to use this macro, first write your letter, and save it in the 'Drafts' folder."
End
Else
For Each oMailItem In myFolderItems
Drafts.AddItem oMailItem.Subject
Next
Drafts.ListIndex = 0
End If


End Sub

Attached Images