Mailing List Management in Outlook 2003
Outlook can be used to manage an announce-only mailing list using VBA. Individuals can subscribe and unsubscribe to the mailing list at will (it's actually a distribution list, as we'll see), so all you need to do is send the message to "the list" and Outlook takes care of who to send it to.
The code is event driven, since the only thing VBA needs to do is look for subscribe and unsubscribe requests, and update the distribution list accordingly.
The code assumes that you have one mailing list; if you have more than one, the code will need to be updated.
' replace with your email address
Const GROUP_EMAIL As String = "your_email_address@yourcompany.com"
' replace with mailing list name
Const GROUP_DL_NAME As String = "Mailing_List_Name"
Const SUBSCRIBE_REQUEST As String = "ADD"
Const UNSUBSCRIBE_REQUEST As String = "REMOVE"
Const ALREADY_SUBSCRIBED As String = "You are already subscribed to the list."
Const NOT_SUBSCRIBED As String = "You are not subscribed to the list."
Const NEW_SUBSCRIBER As String = "Welcome to the mailing list."
Const JUST_LEFT As String = "You have been unsubscribed from the mailing list."
' change this to whatever folder name you want for completed requests
Const REQUESTS_SUBFOLDER = "Requests"
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = GetOutlookApp
Set objNS = GetNS(olApp)
Set Items = GetItems(objNS, olFolderInbox)
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim msgSubject As String
Dim emailAddress As String
Dim destFolder As Outlook.MAPIFolder
Dim EMAIL_FOOTER As String ' pseudo-constant
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
EMAIL_FOOTER = "To subscribe, send a BLANK email with 'ADD your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf & _
"To unsubscribe, send a BLANK email with 'REMOVE your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf
Set Msg = item
msgSubject = Msg.subject
emailAddress = GetEmailAddress(msgSubject)
' process subscribe and unsubscribe requests
If IsSubscribeRequest(msgSubject) Then
' check if the requestor is on mailing list
If IsOnMailingList(emailAddress) Then
' already on list
Call PostMsg(GROUP_DL_NAME, ALREADY_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' not on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' add to mailing list
Call Subscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, NEW_SUBSCRIBER & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
ElseIf IsUnsubscribeRequest(msgSubject) Then ' it's an unsubscribe request
If Not IsOnMailingList(emailAddress) Then
' not on list
Call PostMsg(GROUP_DL_NAME, NOT_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' is on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' remove from mailing list
Call Unsubscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, JUST_LEFT & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Const GROUP_EMAIL As String = "your_email_address@yourcompany.com"
' replace with mailing list name
Const GROUP_DL_NAME As String = "Mailing_List_Name"
Const SUBSCRIBE_REQUEST As String = "ADD"
Const UNSUBSCRIBE_REQUEST As String = "REMOVE"
Const ALREADY_SUBSCRIBED As String = "You are already subscribed to the list."
Const NOT_SUBSCRIBED As String = "You are not subscribed to the list."
Const NEW_SUBSCRIBER As String = "Welcome to the mailing list."
Const JUST_LEFT As String = "You have been unsubscribed from the mailing list."
' change this to whatever folder name you want for completed requests
Const REQUESTS_SUBFOLDER = "Requests"
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = GetOutlookApp
Set objNS = GetNS(olApp)
Set Items = GetItems(objNS, olFolderInbox)
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim msgSubject As String
Dim emailAddress As String
Dim destFolder As Outlook.MAPIFolder
Dim EMAIL_FOOTER As String ' pseudo-constant
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
EMAIL_FOOTER = "To subscribe, send a BLANK email with 'ADD your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf & _
"To unsubscribe, send a BLANK email with 'REMOVE your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf
Set Msg = item
msgSubject = Msg.subject
emailAddress = GetEmailAddress(msgSubject)
' process subscribe and unsubscribe requests
If IsSubscribeRequest(msgSubject) Then
' check if the requestor is on mailing list
If IsOnMailingList(emailAddress) Then
' already on list
Call PostMsg(GROUP_DL_NAME, ALREADY_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' not on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' add to mailing list
Call Subscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, NEW_SUBSCRIBER & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
ElseIf IsUnsubscribeRequest(msgSubject) Then ' it's an unsubscribe request
If Not IsOnMailingList(emailAddress) Then
' not on list
Call PostMsg(GROUP_DL_NAME, NOT_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' is on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' remove from mailing list
Call Unsubscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, JUST_LEFT & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Let's briefly go through how this works.
The code checks incoming items to see which ones are mail items. If it is a mail item, the code checks to see if it's a subscribe request (by looking for 'ADD' in the subject). If so, and the requestor is not already on the distribution, they are added and a message is sent to them welcoming them to the list. Otherwise, they get a message back telling them they're already on it. The request is then moved to the Inbox\Requests folder (or whatever you choose to name it).
If the request is to unsubscribe (boo), the code checks if the requestor is on the list. If not, they're told that, otherwise they're removed from the list and sent back a message wishing them well.
Helper functions
Below are the helper functions used by the event handler above. They may be copied into the same module as the event code above (ThisOutlookSession), or into a separate standard module.
Function IsSubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "ADD"
Dim lensubj As Long
lensubj = Len(SUBSCRIBE_REQUEST)
IsSubscribeRequest = (UCase$(Left$(subj, lensubj)) = SUBSCRIBE_REQUEST)
End Function
Function IsUnsubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "REMOVE"
Dim lensubj As Long
lensubj = Len(UNSUBSCRIBE_REQUEST)
IsUnsubscribeRequest = (UCase$(Left$(subj, lensubj)) = UNSUBSCRIBE_REQUEST)
End Function
Function IsOnMailingList(emailAddress As String) As Boolean
' returns True if given name is on mailing list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Dim i As Long
Set distlst = GetDistList(GROUP_DL_NAME)
For i = 1 To distlst.MemberCount
Set recip = distlst.GetMember(i)
If recip.Address = emailAddress Then
IsOnMailingList = True
Exit For
End If
Next i
End Function
Function Subscribe(emailAddress As String)
' adds given email address to dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.AddMember (recip)
End Function
Function Unsubscribe(emailAddress As String)
' removes given email address from dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.RemoveMember (recip)
End Function
Function GetDistList(ListName As String) As Outlook.DistListItem
' returns a given Distribution List Object
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olContactsFolder As Outlook.Items
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set olContactsFolder = GetItems(olNS, olFolderContacts)
On Error Resume Next
Set GetDistList = olContactsFolder.item(ListName)
End Function
Function IsValidRequest(emailAddress As String, subj As String) As Boolean
' returns True if sender and email address in subject line are a match
' i.e. it will return False if you try and (un)subscribe someone other than yourself
Dim emAddress As String
If IsSubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST))
ElseIf IsUnsubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST))
End If
IsValidRequest = (emailAddress = emAddress)
End Function
Function GetEmailAddress(subj As String) As String
' returns email address being (un)subscribed
If IsSubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST)))
ElseIf IsUnsubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST)))
End If
End Function
Function PostMsg(subject As String, body As String, recip As String)
' sends generic message
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
Set olApp = GetOutlookApp
Set Msg = GetOutlookItem(olApp, olMailItem)
With Msg
.Subject = subject
.Body = body
.Recipients.Add recip
.Send
End With
End Function
' returns true if email subject starts with "ADD"
Dim lensubj As Long
lensubj = Len(SUBSCRIBE_REQUEST)
IsSubscribeRequest = (UCase$(Left$(subj, lensubj)) = SUBSCRIBE_REQUEST)
End Function
Function IsUnsubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "REMOVE"
Dim lensubj As Long
lensubj = Len(UNSUBSCRIBE_REQUEST)
IsUnsubscribeRequest = (UCase$(Left$(subj, lensubj)) = UNSUBSCRIBE_REQUEST)
End Function
Function IsOnMailingList(emailAddress As String) As Boolean
' returns True if given name is on mailing list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Dim i As Long
Set distlst = GetDistList(GROUP_DL_NAME)
For i = 1 To distlst.MemberCount
Set recip = distlst.GetMember(i)
If recip.Address = emailAddress Then
IsOnMailingList = True
Exit For
End If
Next i
End Function
Function Subscribe(emailAddress As String)
' adds given email address to dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.AddMember (recip)
End Function
Function Unsubscribe(emailAddress As String)
' removes given email address from dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.RemoveMember (recip)
End Function
Function GetDistList(ListName As String) As Outlook.DistListItem
' returns a given Distribution List Object
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olContactsFolder As Outlook.Items
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set olContactsFolder = GetItems(olNS, olFolderContacts)
On Error Resume Next
Set GetDistList = olContactsFolder.item(ListName)
End Function
Function IsValidRequest(emailAddress As String, subj As String) As Boolean
' returns True if sender and email address in subject line are a match
' i.e. it will return False if you try and (un)subscribe someone other than yourself
Dim emAddress As String
If IsSubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST))
ElseIf IsUnsubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST))
End If
IsValidRequest = (emailAddress = emAddress)
End Function
Function GetEmailAddress(subj As String) As String
' returns email address being (un)subscribed
If IsSubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST)))
ElseIf IsUnsubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST)))
End If
End Function
Function PostMsg(subject As String, body As String, recip As String)
' sends generic message
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
Set olApp = GetOutlookApp
Set Msg = GetOutlookItem(olApp, olMailItem)
With Msg
.Subject = subject
.Body = body
.Recipients.Add recip
.Send
End With
End Function
One-off loop code
What happens when you are out of the office or have left for the day? You shut off your computer, but the requests keep piling up. So we'll need a standalone procedure that loops through the Inbox and looks for any existing requests.
' replace with your email address
Const GROUP_EMAIL As String = "your_email_address@yourcompany.com"
' replace with mailing list name
Const GROUP_DL_NAME As String = "Mailing_List_Name"
Const SUBSCRIBE_REQUEST As String = "ADD"
Const UNSUBSCRIBE_REQUEST As String = "REMOVE"
Const ALREADY_SUBSCRIBED As String = "You are already subscribed to the list."
Const NOT_SUBSCRIBED As String = "You are not subscribed to the list."
Const NEW_SUBSCRIBER As String = "Welcome to the mailing list."
Const JUST_LEFT As String = "You have been unsubscribed from the mailing list."
' change this to whatever folder name you want for completed requests
Const REQUESTS_SUBFOLDER = "Requests"
Sub ProcessInboxRequests()
' loop through inbox for accumulated add/remove requests and process them
On Error GoTo ErrorHandler
Dim Itms As Outlook.Items
Dim Msg As Outlook.MailItem
Dim i As Long
Dim msgSubject As String
Dim emailAddress As String
Dim destFolder As Outlook.MAPIFolder
Dim EMAIL_FOOTER As String ' pseudo-constant
EMAIL_FOOTER = "To subscribe, send a BLANK email with 'ADD your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf & _
"To unsubscribe, send a BLANK email with 'REMOVE your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf
Set Itms = GetItems(GetNS(GetOutlookApp), olFolderInbox)
' loop backwards in case we have to move multiple emails
For i = Itms.Count To 1 Step -1
Set Msg = Itms.item(i)
msgSubject = Msg.subject
emailAddress = GetEmailAddress(msgSubject)
' process subscribe and unsubscribe requests
If IsSubscribeRequest(msgSubject) Then
' check if the requestor is on mailing list
If IsOnMailingList(emailAddress) Then
' already on list
Call PostMsg(GROUP_DL_NAME, ALREADY_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' not on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' add to mailing list
Call Subscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, NEW_SUBSCRIBER & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
ElseIf IsUnsubscribeRequest(msgSubject) Then ' it's an unsubscribe request
If Not IsOnMailingList(emailAddress) Then
' not on list
Call PostMsg(GROUP_DL_NAME, NOT_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' is on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' remove from mailing list
Call Unsubscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, JUST_LEFT & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
End If
Next i
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetOutlookApp() As Outlook.Application
' returns native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
' returns native NameSpace Object
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Outlook.NameSpace, _
folder As OlDefaultFolders) As Outlook.Items
' returns Items collection for specified default folder
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Function GetEmailAddress(subj As String) As String
' returns email address being (un)subscribed
If IsSubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST)))
ElseIf IsUnsubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST)))
End If
End Function
Function IsSubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "ADD"
Dim lensubj As Long
lensubj = Len(SUBSCRIBE_REQUEST)
IsSubscribeRequest = (UCase$(Left$(subj, lensubj)) = SUBSCRIBE_REQUEST)
End Function
Function IsUnsubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "REMOVE"
Dim lensubj As Long
lensubj = Len(UNSUBSCRIBE_REQUEST)
IsUnsubscribeRequest = (UCase$(Left$(subj, lensubj)) = UNSUBSCRIBE_REQUEST)
End Function
Function IsOnMailingList(emailAddress As String) As Boolean
' returns True if given name is on mailing list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Dim i As Long
Set distlst = GetDistList(GROUP_DL_NAME)
For i = 1 To distlst.MemberCount
Set recip = distlst.GetMember(i)
If recip.Address = emailAddress Then
IsOnMailingList = True
Exit For
End If
Next i
End Function
Function Subscribe(emailAddress As String)
' adds given email address to dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.AddMember (recip)
End Function
Function Unsubscribe(emailAddress As String)
' removes given email address from dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.RemoveMember (recip)
End Function
Function GetDistList(ListName As String) As Outlook.DistListItem
' returns a given Distribution List Object
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olContactsFolder As Outlook.Items
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set olContactsFolder = GetItems(olNS, olFolderContacts)
On Error Resume Next
Set GetDistList = olContactsFolder.item(ListName)
End Function
Function IsValidRequest(emailAddress As String, subj As String) As Boolean
' returns True if sender and email address in subject line are a match
' i.e. it will return False if you try and (un)subscribe someone other than yourself
Dim emAddress As String
If IsSubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST))
ElseIf IsUnsubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST))
End If
IsValidRequest = (emailAddress = emAddress)
End Function
Function PostMsg(subject As String, body As String, recip As String)
' sends generic message
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
Set olApp = GetOutlookApp
Set Msg = GetOutlookItem(olApp, olMailItem)
With Msg
.subject = subject
.body = body
.Recipients.Add recip
.Send
End With
End Function
Const GROUP_EMAIL As String = "your_email_address@yourcompany.com"
' replace with mailing list name
Const GROUP_DL_NAME As String = "Mailing_List_Name"
Const SUBSCRIBE_REQUEST As String = "ADD"
Const UNSUBSCRIBE_REQUEST As String = "REMOVE"
Const ALREADY_SUBSCRIBED As String = "You are already subscribed to the list."
Const NOT_SUBSCRIBED As String = "You are not subscribed to the list."
Const NEW_SUBSCRIBER As String = "Welcome to the mailing list."
Const JUST_LEFT As String = "You have been unsubscribed from the mailing list."
' change this to whatever folder name you want for completed requests
Const REQUESTS_SUBFOLDER = "Requests"
Sub ProcessInboxRequests()
' loop through inbox for accumulated add/remove requests and process them
On Error GoTo ErrorHandler
Dim Itms As Outlook.Items
Dim Msg As Outlook.MailItem
Dim i As Long
Dim msgSubject As String
Dim emailAddress As String
Dim destFolder As Outlook.MAPIFolder
Dim EMAIL_FOOTER As String ' pseudo-constant
EMAIL_FOOTER = "To subscribe, send a BLANK email with 'ADD your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf & _
"To unsubscribe, send a BLANK email with 'REMOVE your-email-address' in the subject to: " & _
GROUP_EMAIL & "." & vbCrLf
Set Itms = GetItems(GetNS(GetOutlookApp), olFolderInbox)
' loop backwards in case we have to move multiple emails
For i = Itms.Count To 1 Step -1
Set Msg = Itms.item(i)
msgSubject = Msg.subject
emailAddress = GetEmailAddress(msgSubject)
' process subscribe and unsubscribe requests
If IsSubscribeRequest(msgSubject) Then
' check if the requestor is on mailing list
If IsOnMailingList(emailAddress) Then
' already on list
Call PostMsg(GROUP_DL_NAME, ALREADY_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' not on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' add to mailing list
Call Subscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, NEW_SUBSCRIBER & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
ElseIf IsUnsubscribeRequest(msgSubject) Then ' it's an unsubscribe request
If Not IsOnMailingList(emailAddress) Then
' not on list
Call PostMsg(GROUP_DL_NAME, NOT_SUBSCRIBED & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
GoTo ProgramExit
Else ' is on mailing list
If IsValidRequest(Msg.SenderEmailAddress, msgSubject) Then
' remove from mailing list
Call Unsubscribe(emailAddress)
' send confirmation message
Call PostMsg(GROUP_DL_NAME, JUST_LEFT & vbCrLf & EMAIL_FOOTER, Msg.SenderEmailAddress)
' move request msg to subfolder
If Not CheckForFolder(REQUESTS_SUBFOLDER) Then
Set destFolder = CreateSubFolder(REQUESTS_SUBFOLDER)
Else
Set destFolder = Session.GetDefaultFolder(olFolderInbox).Folders(REQUESTS_SUBFOLDER)
End If
Msg.Move destFolder
GoTo ProgramExit
End If
End If
End If
Next i
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetOutlookApp() As Outlook.Application
' returns native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
' returns native NameSpace Object
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Outlook.NameSpace, _
folder As OlDefaultFolders) As Outlook.Items
' returns Items collection for specified default folder
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Function GetEmailAddress(subj As String) As String
' returns email address being (un)subscribed
If IsSubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST)))
ElseIf IsUnsubscribeRequest(subj) Then
GetEmailAddress = Trim$(Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST)))
End If
End Function
Function IsSubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "ADD"
Dim lensubj As Long
lensubj = Len(SUBSCRIBE_REQUEST)
IsSubscribeRequest = (UCase$(Left$(subj, lensubj)) = SUBSCRIBE_REQUEST)
End Function
Function IsUnsubscribeRequest(subj As String) As Boolean
' returns true if email subject starts with "REMOVE"
Dim lensubj As Long
lensubj = Len(UNSUBSCRIBE_REQUEST)
IsUnsubscribeRequest = (UCase$(Left$(subj, lensubj)) = UNSUBSCRIBE_REQUEST)
End Function
Function IsOnMailingList(emailAddress As String) As Boolean
' returns True if given name is on mailing list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Dim i As Long
Set distlst = GetDistList(GROUP_DL_NAME)
For i = 1 To distlst.MemberCount
Set recip = distlst.GetMember(i)
If recip.Address = emailAddress Then
IsOnMailingList = True
Exit For
End If
Next i
End Function
Function Subscribe(emailAddress As String)
' adds given email address to dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.AddMember (recip)
End Function
Function Unsubscribe(emailAddress As String)
' removes given email address from dist list
Dim distlst As Outlook.DistListItem
Dim recip As Outlook.recipient
Set distlst = GetDistList(GROUP_DL_NAME)
Set recip = Session.CreateRecipient(emailAddress)
distlst.RemoveMember (recip)
End Function
Function GetDistList(ListName As String) As Outlook.DistListItem
' returns a given Distribution List Object
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olContactsFolder As Outlook.Items
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set olContactsFolder = GetItems(olNS, olFolderContacts)
On Error Resume Next
Set GetDistList = olContactsFolder.item(ListName)
End Function
Function IsValidRequest(emailAddress As String, subj As String) As Boolean
' returns True if sender and email address in subject line are a match
' i.e. it will return False if you try and (un)subscribe someone other than yourself
Dim emAddress As String
If IsSubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(SUBSCRIBE_REQUEST))
ElseIf IsUnsubscribeRequest(subj) Then
emAddress = Right$(subj, Len(subj) - Len(UNSUBSCRIBE_REQUEST))
End If
IsValidRequest = (emailAddress = emAddress)
End Function
Function PostMsg(subject As String, body As String, recip As String)
' sends generic message
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
Set olApp = GetOutlookApp
Set Msg = GetOutlookItem(olApp, olMailItem)
With Msg
.subject = subject
.body = body
.Recipients.Add recip
.Send
End With
End Function
After writing the above code, I found an add-in that can do this: Outlook Toolbox (it's not free, though).
