#1
|
|||
|
|||
BounceBack Email VBA Code
I have pasted the following code into an Outlook 2010 module and it works perfectly apart from I want it to extract every bounced back email address in a "Failed Delivery" Email not just the first one within the email. Postmaster mail failure emails report in multiples of failed email addresses within one email not just one. I read somewhere that it involves adding an element called MyRegExp Global property to TRUE. But unfortunately my VBA coding skills are limited. Would value anyones help immensely.
Sub Extract_Invalid_To_Excel() Dim olApp As Outlook.Application Dim olExp As Outlook.Explorer Dim olFolder As Outlook.MAPIFolder Dim obj As Object Dim stremBody As String Dim stremSubject As String Dim i As Long Dim x As Long Dim count As Long Dim RegEx As Object Set RegEx = CreateObject("VBScript.RegExp") 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 olExp = olApp.ActiveExplorer Set olFolder = olExp.CurrentFolder 'Open Excel Set xlApp = GetExcelApp xlApp.Visible = True If xlApp Is Nothing Then GoTo ExitProc Set xlwkbk = xlApp.Workbooks.Add Set xlwksht = xlwkbk.Sheets(1) Set xlRng = xlwksht.Range("A1") xlRng.Value = "Bounced email addresses" 'Set count of email objects count = olFolder.Items.count 'counter for excel sheet i = 0 'counter for emails x = 1 For Each obj In olFolder.Items xlApp.StatusBar = x & " of " & count & " emails completed" stremBody = obj.Body stremSubject = obj.Subject 'Check for keywords in email before extracting address If checkEmail(stremBody) = True Then 'MsgBox ("finding email: " & stremBody) RegEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b" RegEx.IgnoreCase = True RegEx.MultiLine = False Set olMatches = RegEx.Execute(stremBody) For Each match In olMatches xlwksht.Cells(i + 2, 1).Value = match i = i + 1 Next match 'TODO move or mark the email that had the address extracted Else 'To view the items that aren't being parsed uncomment the following line 'MsgBox (stremBody) End If x = x + 1 Next obj xlApp.ScreenUpdating = True MsgBox ("Invalid Email addresses are done being extracted") 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 Function checkEmail(ByVal Body As String) As Boolean Dim keywords(29) As String keywords(0) = "Delivery to the following recipients failed" keywords(1) = "user unknown" keywords(2) = "The e-mail account does not exist" keywords(3) = "undeliverable address" keywords(4) = "550 Host unknown" keywords(5) = "No such user" keywords(6) = "Addressee unknown" keywords(7) = "Mailaddress is administratively disabled" keywords(8) = "unknown or invalid" keywords(9) = "Recipient address rejected" keywords(10) = "disabled or discontinued" keywords(11) = "Recipient verification failed" keywords(12) = "no mailbox here by that name" keywords(13) = "This user doesn't have a yahoo.com account" keywords(14) = "No mailbox found" keywords(15) = "not our customer" keywords(16) = "mailbox unavailable" keywords(17) = "Mailbox disabled" keywords(18) = "mailbox is inactive" keywords(19) = "address error" keywords(20) = "unknown recipient" keywords(21) = "unknown user" keywords(22) = "mail to the recipient is not accepted on this system" keywords(23) = "no user with that name" keywords(24) = "invalid recipient" keywords(25) = “message could not be delivered” keywords(26) = “Host or domain name not found” keywords(27) = “Connection timed out” keywords(28) = “The following recipient(s) could not be reached” 'Default value checkEmail = False For Each word In keywords If InStr(1, Body, word, vbTextCompare) > 1 Then checkEmail = True Exit For End If Next word End Function Thanking you very much, in advance. WiltsBoy |
Tags |
bounce back, outlook 2010, vba code |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Outlook Email messsages do not show sender unless you open the email | jdesnoue | Outlook | 5 | 04-22-2013 09:10 PM |
VBL code for automatic attachment of file into email | DrLoveday1 | Outlook | 1 | 04-12-2013 05:36 AM |
Mail Merge to email, changing images on email layout | ginelli | Mail Merge | 18 | 02-23-2013 09:47 AM |
Can't create new email or access email acounts Outlook 2003 | onthebeaches | Outlook | 1 | 02-20-2012 10:21 PM |
contacts email by colour code | mikemans | Outlook | 0 | 10-31-2009 01:47 AM |