Bounced email list maker
February 26, 2009 @ 10:48 AM by JP • 1 views • No Comments »
I'd like to share some Outlook VBA code I wrote for a site visitor who asked for something to process bounced emails. He sends out marketing emails and gets undeliverable reports back, usually when the email address is invalid. He'd like to take the email addresses from the bounce emails and create an Excel worksheet with them.
The bounce emails are collected into a subfolder called "Bounced." There are several different types of bounces, because each mail server sends a message formatted slightly differently.
After setting a reference to the Bounced folder, we loop through the folder and check each email's subject to see which type of email it is. Then we parse the body for the email address and add it to an array.
Finally, the array is dumped into a worksheet. I listed two ways to write to the worksheet: the loop and resize methods. Everything is late bound so you won't need to set a reference to the Excel Object Library.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim obj As Object
Dim emItm As Outlook.MailItem
Dim stremBody As String
Dim stremSubject As String
Dim lFirstPos As Long
Dim lLastPos As Long
Dim BadUserList As Variant
Dim i As Long
Dim xlApp As Object 'Excel.Application
Dim xlwkbk As Object 'Excel.Workbook
Dim xlwksht As Object 'Excel.Worksheet
Dim xlRng As Object 'Excel.Range
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Bounced")
' set up size of variant
ReDim BadUserList(olFolder.Items.Count)
' initialize variant position counter
i = 0
' parse each message in the folder holding the bounced emails
For Each obj In olFolder.Items
Set emItm = obj
stremBody = emItm.Body
stremSubject = emItm.Subject
Select Case stremSubject
Case "Delivery Failure"
lFirstPos = InStr(stremBody, "Failed Recipient: ") + 18
lLastPos = InStr(lFirstPos + 1, stremBody, vbCr)
Case "Returned mail: see transcript for details"
lFirstPos = InStr(stremBody, "via localhost, to <") + 19
lLastPos = InStr(lFirstPos + 1, stremBody, ">")
Case "Delivery Status Notification (Failure)"
lFirstPos = InStr(stremBody, "destination mail server.") + 35
If lFirstPos = 35 Then ' those words aren't in the email, must be the
' other kind
lFirstPos = InStr(stremBody, "recipients failed") + 29
End If
lLastPos = InStr(lFirstPos + 1, stremBody, vbCr)
lLastPos = InStr(lLastPos + 1, stremBody, vbCr)
lLastPos = InStr(lLastPos + 1, stremBody, vbCr)
End Select
BadUserList(i) = Mid$(stremBody, lFirstPos, lLastPos - (lFirstPos))
i = i + 1
Next obj
' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc
Set xlwkbk = xlApp.Workbooks.Add
Set xlwksht = xlwkbk.Sheets(1)
Set xlRng = xlwksht.Range("A1")
xlApp.ScreenUpdating = False
xlRng.Value = "Bounced email addresses"
' resize version
xlRng.Offset(1, 0).Resize(UBound(BadUserList) + 1).Value = xlApp.Transpose(BadUserList)
' loop version
'For i = LBound(BadUserList) To UBound(BadUserList)
' Cells(i + 2, 1).Value = BadUserList(i)
'Next i
' optional
'ActiveSheet.UsedRange.Columns.AutoFit
xlApp.Visible = True
xlApp.ScreenUpdating = True
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set emItm = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
Function GetExcelApp() As Object
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0
End Function
Today's challenge: add code to move the processed emails to another folder, leaving the untouched ones in the Bounced folder – Any takers?
Optional: add toolbar button to run code on demand:
See How to assign a macro to a toolbar button or run the following code in a standard module in Outlook VBIDE:
' based on http://www.slovaktech.com/code_samples.htm#HyperlinkButton
' run once to add the button to your toolbar
Dim objButton As Office.CommandBarButton
Dim objBar As Office.CommandBar
Dim strCaption As String
Dim strURL As String
Set objBar = ActiveExplorer.CommandBars("Advanced")
Set objButton = objBar.Controls.Add(msoControlButton)
If Not objBar.Visible Then
objBar.Visible = True
End If
strCaption = "Process Bounced Msgs"
With objButton
.Caption = strCaption
.OnAction = "Extract_Invalid_To_Excel"
.BeginGroup = True
End With
Set objButton = Nothing
Set objBar = Nothing
End Sub
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Excel Tutorial Series – Advanced Lookup/Counting Functions
Next Post: Amazon Ad Link Generator add-in for Excel
outlook does an error telling " runtime error"5" invalida procedure call or argument.
BadUserList(i) = Mid$(stremBody, lFirstPos, lLastPos – (lFirstPos))
Can you help me?
Nick,
What are the values of stremBody, lFirstPos and lLastPos when the error occurs?
JP – I get a 'Run-time error 13: Type mismatch'
which debugs to line:
Set emItm = obj
any thoughts?
emItm is declared as Outlook.MailItem, so the Bounced folder can only contain Mailitems.