Newsletter Unsubscribe and Delivery Failure in Outlook

I have a web site from which I weekly send out newsletters to 15-20.000 members. The sending of the newsletters is fully automated but I use two VBscript Macros in Outlook to handle Delivery Failures (eg. User Unknown, Domain not Found, Mailbox Full) and the manual Unsubscribe Requests I get. I know I can buy or subscribe to tools that automate this for me but I find it easy enough to handle it manually in Outlook using these two Macros. Nothing fancy or hitech but maybe it helps someone else out.

The Macros are written in VBscript and used in Outlook 2003. I have not yet tested them in Outlook 2007 but I expect they will work there too. (I have just installed a new computer with Windows Vista and Office 2007 but have not yet had the time to move everything there)

How I use the Macros:

  1. Newsletters are automatically sent to members
  2. Delivery Failures and Unsubscribe emails land in my Outlook Inbox and I move them to a Errors and Unsubscribe folder respectively (I could/should create an inbox rule that based on recipient automatically move them to the correct folder)
  3. I run the Macros to extract email addresses
  4. I paste the extracted email addresses into a admin page that I have created for my site that remove them from the database, send a confirmation email etc.

Script 1 – GetEmailSender:
Extracts email sender. Runs on all mailitems in current folder that are unread. This is the Macro I run on Unsubscribe emails.
[Update: Download this macro as a text file here.]

Script 2 – GetEmailFromBody:
Extracts first found email address from body. Runs on all items in current folder. This is the Macro I run on Delivery Failure emails.
[Update: Download this macro as a text file here.]

(To add the Macros in Outlook: Copy code from below, goto to Tools – Macros – Visual Basic Editor – and paste the code there)

Sub GetEmailSender()

' ------------------------------------------------
' --- You may use and/or change this code freely
' --- provided you keep this message
' ---
' --- Description:
' --- Extracts email sender
' --- Runs on all mailitems in current folder that
' --- are unread
' ---
' --- By Max Flodén 2006 - http://www.tjitjing.com
' ------------------------------------------------

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace

Dim mySelection As Selection

Dim myItem As Object
Dim myMailItemLog As Outlook.MailItem

Dim myFolder As Outlook.MAPIFolder

Dim strContactFolderName As String 'Directly under Public Folders\All Public Folders
Dim strNewsletterCategoryName As String
Dim strMailItemSender As String
Dim strMailTo As String
Dim intMessageCount As Integer
Dim bolDebug As Boolean 'If true error messages will be shown
Dim strTemp As String

Set myNameSpace = myOlApp.GetNamespace("MAPI")

'Debug settings
bolDebug = True

'Ask to continue - start warning
intRes = MsgBox("This macro will go thru all items in folder." & vbCrLf & "Would like to continue?", vbYesNo + vbQuestion, "Get Email Sender")
If Not intRes = vbYes Then Exit Sub

'Create a new email to use as log file
Set myMailItemLog = myOlApp.CreateItem(olMailItem)
myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
myMailItemLog.Subject = "Email from Body - " & Now()
myMailItemLog.BodyFormat = olFormatPlain
myMailItemLog.Body = Now() & " Starting..." & vbCrLf & vbCrLf

'Go thru all items in folder
intMessageCount = 0
intMsgCount_Error = 0
For Each myItem In myOlApp.ActiveExplorer.CurrentFolder.Items

If Not TypeName(myItem) = "MailItem" Then
'Errorlog
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - MESSAGE TYPE IS NOT MAILITEM." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
ElseIf myItem.UnRead Then
myMailItemLog.Body = myMailItemLog.Body & myItem.SenderEmailAddress & vbCrLf
myItem.UnRead = False
myItem.FlagStatus = olFlagMarked
intMessageCount = intMessageCount + 1
End If

Next

'Done - write to log and show done message
myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & "."
myMailItemLog.Display
MsgBox Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & ".", vbInformation, "Done"

End Sub


Sub GetEmailFromBody()

' ------------------------------------------------
' --- You may use and/or change this code freely
' --- provided you keep this message
' ---
' --- Description:
' --- Extracts first found email address from body
' --- (used to extract email address from
' --- error messages/returned email)
' --- Runs on all items in current folder
' ---
' --- By Max Flodén 2006 - http://www.tjitjing.com
' ------------------------------------------------

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySelection As Selection
Dim myItem As Object
Dim myMailItemLog As Outlook.MailItem
Dim myFolder As Outlook.MAPIFolder

Dim strContactFolderName As String 'Directly under Public Folders\All Public Folders
Dim strNewsletterCategoryName As String
Dim strMailItemSender As String
Dim strMailTo As String
Dim intMessageCount As Integer
Dim bolDebug As Boolean 'If true no emails will be sent
Dim bolOnly550 As Boolean 'Only extract email addresses that are 'user not found' (#550) etc.
Dim strTemp As String

Set myNameSpace = myOlApp.GetNamespace("MAPI")

'Debug settings
bolDebug = True

'Ask to continue - start warning
intRes = MsgBox("This macro will go thru all items in folder." & vbCrLf & "Would like to extract only addresses that have 'user not found'?", vbYesNoCancel + vbQuestion, "Get Email from Body")
If intRes = vbCancel Then
Exit Sub
ElseIf intRes = vbYes Then
bolOnly550 = True
Else
bolOnly550 = False
End If

'Create a new email to use as log file
Set myMailItemLog = myOlApp.CreateItem(olMailItem)
myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
myMailItemLog.Subject = "Email from Body - " & Now()
myMailItemLog.BodyFormat = olFormatPlain
myMailItemLog.Body = Now() & " Starting..." & vbCrLf & vbCrLf

'Go thru all items in folder
intMessageCount = 0
intMsgCount_Error = 0
For Each myItem In myOlApp.ActiveExplorer.CurrentFolder.Items

If Not TypeName(myItem) = "ReportItem" And Not TypeName(myItem) = "MailItem" Then
'Errorlog
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - MESSAGE TYPE IS NOT REPORTITEM OR MAILITEM." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else

'Check type is 550 - user not found/inactive etc
If bolOnly550 And _
(InStr(myItem.Body, "550") = 0) And _
(InStr(myItem.Body, "554") = 0) And _
(InStr(myItem.Body, "unknown user") = 0) And _
(InStr(myItem.Body, "user unknown") = 0) And _
(InStr(myItem.Body, "no mailbox here by that name") = 0) And _
(InStr(myItem.Body, "no such user") = 0) And _
(InStr(myItem.Body, "bad address") = 0) And _
(InStr(myItem.Body, "Host or domain name not found") = 0) And _
(InStr(myItem.Body, "e-mail account does not exist") = 0) Then
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NOT 550 OR Host or domain name not found MESSAGE." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else

'Extract email address from body
intPos = InStr(myItem.Body, "@")
If intPos = 0 Then
'No email address found
If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & "ERROR - NO EMAIL ADDRESS FOUND IN MESSAGE." & vbCrLf
myItem.UnRead = True
intMsgCount_Error = intMsgCount_Error + 1
Else
'Get right of @
intPos_Space = InStr(intPos, myItem.Body, " ")
intPos_Bracket = InStr(intPos, myItem.Body, ">")
If (intPos_Space < intpos_bracket =" 0)" intpos_temp =" intPos_Space" intpos_temp =" intPos_Bracket" strtemp =" Left(myItem.Body," intpos_space =" InStrRev(strTemp," intpos_bracket =" InStrRev(strTemp,"> intPos_Bracket) Or (intPos_Bracket = 0) Then
intPos_Temp = intPos_Space
Else
intPos_Temp = intPos_Bracket
End If
strTemp = Mid(strTemp, intPos_Temp + 1)
'Write to log
myMailItemLog.Body = myMailItemLog.Body & strTemp & vbCrLf
myItem.UnRead = False
intMessageCount = intMessageCount + 1
End If
End If
End If

Next

'Done - write to log and show done message
myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & "."
myMailItemLog.Display
MsgBox Now() & " Done. Email addresses extracted: " & intMessageCount & ". Email addresses NOT extracted: " & intMsgCount_Error & ".", vbInformation, "Done"

End Sub

Published By
Categorized as Outlook

6 comments

  1. If (intPos_Space < intpos_bracket =" 0)" intpos_temp =" intPos_Space" intpos_temp =" intPos_Bracket" strtemp =" Left(myItem.Body," intpos_space =" InStrRev(strTemp," intpos_bracket =" InStrRev(strTemp,"> intPos_Bracket) Or (intPos_Bracket = 0) Then

    I am getting an error in Visual Studio for this line. I think a few of the lines of code got jumbled together when you pasted into the blog. Any help on that would be great.

    Reply

  2. Here is the code with a few changes. It doesn’t error in my computer anymore.

    – Jess

    Sub GetEmailFromBody()

    ‘ ————————————————
    ‘ — You may use and/or change this code freely
    ‘ — provided you keep this message
    ‘ —
    ‘ — Description:
    ‘ — Extracts first found email address from body
    ‘ — (used to extract email address from
    ‘ — error messages/returned email)
    ‘ — Runs on all items in current folder
    ‘ —
    ‘ — By Max Flodén 2006 – http://www.tjitjing.com
    ‘ ————————————————

    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim mySelection As Selection
    Dim myItem As Object
    Dim myMailItemLog As Outlook.MailItem
    Dim myFolder As Outlook.MAPIFolder

    Dim strContactFolderName As String ‘Directly under Public Folders\All Public Folders
    Dim strNewsletterCategoryName As String
    Dim strMailItemSender As String
    Dim strMailTo As String
    Dim intMessageCount As Integer
    Dim bolDebug As Boolean ‘If true no emails will be sent
    Dim bolOnly550 As Boolean ‘Only extract email addresses that are ‘user not found’ (#550) etc.
    Dim strTemp As String

    Set myNameSpace = myOlApp.GetNamespace(“MAPI”)

    ‘Debug settings
    bolDebug = True

    ‘Ask to continue – start warning
    intRes = MsgBox(“This macro will go thru all items in folder.” & vbCrLf & “Would like to extract only addresses that have ‘user not found’?”, vbYesNoCancel + vbQuestion, “Get Email from Body”)
    If intRes = vbCancel Then
    Exit Sub
    ElseIf intRes = vbYes Then
    bolOnly550 = True
    Else
    bolOnly550 = False
    End If

    ‘Create a new email to use as log file
    Set myMailItemLog = myOlApp.CreateItem(olMailItem)
    myMailItemLog.Recipients.Add (myNameSpace.CurrentUser)
    myMailItemLog.Subject = “Email from Body – ” & Now()
    myMailItemLog.BodyFormat = olFormatPlain
    myMailItemLog.Body = Now() & ” Starting…” & vbCrLf & vbCrLf

    ‘Go thru all items in folder
    intMessageCount = 0
    intMsgCount_Error = 0
    For Each myItem In myOlApp.ActiveExplorer.CurrentFolder.Items

    If Not TypeName(myItem) = “ReportItem” And Not TypeName(myItem) = “MailItem” Then
    ‘Errorlog
    If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & “ERROR – MESSAGE TYPE IS NOT REPORTITEM OR MAILITEM.” & vbCrLf
    myItem.UnRead = True
    intMsgCount_Error = intMsgCount_Error + 1
    Else

    ‘Check type is 550 – user not found/inactive etc
    If bolOnly550 And _
    (InStr(myItem.Body, “550”) = 0) And _
    (InStr(myItem.Body, “554”) = 0) And _
    (InStr(myItem.Body, “unknown user”) = 0) And _
    (InStr(myItem.Body, “user unknown”) = 0) And _
    (InStr(myItem.Body, “no mailbox here by that name”) = 0) And _
    (InStr(myItem.Body, “no such user”) = 0) And _
    (InStr(myItem.Body, “bad address”) = 0) And _
    (InStr(myItem.Body, “Host or domain name not found”) = 0) And _
    (InStr(myItem.Body, “e-mail account does not exist”) = 0) Then
    If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & “ERROR – NOT 550 OR Host or domain name not found MESSAGE.” & vbCrLf
    myItem.UnRead = True
    intMsgCount_Error = intMsgCount_Error + 1
    Else

    ‘Extract email address from body
    intPos = InStr(myItem.Body, “@”)
    ‘myMailItemLog.Body = myMailItemLog.Body & intPos & vbCrLf
    If intPos = 0 Then
    ‘No email address found
    If bolDebug Then myMailItemLog.Body = myMailItemLog.Body & “ERROR – NO EMAIL ADDRESS FOUND IN MESSAGE.” & vbCrLf
    myItem.UnRead = True
    intMsgCount_Error = intMsgCount_Error + 1
    Else
    ‘Get right of @
    intpos_space = InStr(intPos, myItem.Body, ” “)
    ‘strEnter = “” & Chr(13)
    ‘intpos_enter = InStr(intpos, myItem.Body, strEnter)
    ‘myMailItemLog.Body = myMailItemLog.Body & myItem.Body & vbCrLf
    intpos_bracket = InStr(intPos, myItem.Body, “>”)
    ‘myMailItemLog.Body = myMailItemLog.Body & intpos_bracket & vbCrLf
    If (intpos_space < intpos_bracket) Then
    intPos_Temp = intpos_space
    ElseIf (intpos_space = 0 And intpost_bracket = 0) Then
    intPos_Temp = Len(myItem.Body)
    ‘intPos_Temp = 0
    Else
    intPos_Temp = intpos_bracket
    End If

    strTemp = Left(myItem.Body, intPos_Temp + 1)

    ‘myMailItemLog.Body = myMailItemLog.Body & strTemp & vbCrLf

    ‘Get left of @
    intpos_space = InStrRev(strTemp, ” “)
    intpos_bracket = InStrRev(strTemp, “<")
    ‘myMailItemLog.Body = myMailItemLog.Body & intpos_bracket & vbCrLf & intpos_space & vbCrLf

    If (intpos_space > intpos_bracket) Then
    intPos_Temp = intpos_space
    Else
    intPos_Temp = intpos_bracket
    End If
    ‘myMailItemLog.Body = myMailItemLog.Body & intPos_Temp & “test” & vbCrLf
    strTemp = Mid(strTemp, intPos_Temp + 1)
    strTemp = Replace(Replace(strTemp, “” & vbCrLf, “”), “” & vbCr, “”)
    ‘Write to log
    myMailItemLog.Body = myMailItemLog.Body & strTemp & vbCrLf
    myItem.UnRead = False
    intMessageCount = intMessageCount + 1
    End If
    End If
    End If

    Next

    ‘Done – write to log and show done message
    myMailItemLog.Body = myMailItemLog.Body & vbCrLf & Now() & ” Done. Email addresses extracted: ” & intMessageCount & “. Email addresses NOT extracted: ” & intMsgCount_Error & “.”
    myMailItemLog.Display
    MsgBox Now() & ” Done. Email addresses extracted: ” & intMessageCount & “. Email addresses NOT extracted: ” & intMsgCount_Error & “.”, vbInformation, “Done”

    End Sub

    Reply

  3. Hello

    I am looking for a Macro that actually extract the To email address from emails in an Outlook forlder.

    I appreciate any help with it

    Thanks,
    Jorge

    Reply

  4. I have added the macros as downloadable textfiles.
    If don’t download and use the text files, when you copy and paste – look out for added line breaks in the code that you will need to remove.

    Jorge – you should fairly easily be able to modify any of these two macros to do what you’re looking for.

    Reply

Leave a comment

Your email address will not be published. Required fields are marked *