Solved: Parse email body for email addresses and write them to Excel...Help with Troubleshoot

Hi,

I have written a script that parses the bodies of emails for email addresses and writes them to an Excel spreadsheet. I am using a regex to match and an array to store the strings. The script works great except for the three issues below.

BTW, this is being used to get the addresses out of returned mail failures so they can be removed from our database. I only have about 3000+ failures....lol

Issue 1:
I have the all the failure notices in an archive folder to remove them from the server until parsing and then deletion. For the life of me, I cannot reference the archive PST folder. :banghead: It always defaults to the Personal Folders / Inbox / Folder Name Here. The actual path is Archive E-Mails / Inbox / Mail Failures.

Issue 2:
Currently, I have it set to a test folder inside the default inbox labeled "Test". Sometimes it runs fine and sometimes Outlook quits responding and had to be manually shut down. It has never run properly with more than 30 emails in the folder. Even then it's hit and missif it works. Remember I have 3000+ emails that need to be parsed.:dunno

Issue 3:
This should be simple. I would like the output to be to the same Excel file each time, create a new sheet, and plug in the date in A1. Simply for tracking purposes.

I am not asking someone to do the work for me, but please point me in the right direction to fix these issues. My script is realy useless to me without a minimum of issue 2 being corrected. Thank you in advance for everyones help and input.

[VBA]
Sub badAddress()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim regEx As Object
Dim olMatches As Object
Dim strBody As String
Dim bcount As String
Dim lFirstPos As Long
Dim lLastPos As Long
Dim badAddresses 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("Test")
Set regEx = CreateObject("VBScript.RegExp")
'define regular expression
regEx.Pattern = "[\_]*([a-z0-9]+(\.|\_*)?)+@([a-z][a-z0-9\-]+(\.|\-*\.))+[a-z]{2,6}"
regEx.IgnoreCase = True
regEx.Multiline = True
' set up size of variant
bcount = olFolder.Items.Count
ReDim badAddresses(1 To bcount) As String
' initialize variant position counter
i = 0
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = Item.Body
Set olMatches = regEx.Execute(strBody)
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
End If
Next
' 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(badAddresses) + 1).Value = xlApp.Transpose(badAddresses)
xlApp.Visible = True
xlApp.ScreenUpdating = True
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set badAddresses = 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

[/VBA]

With Regex, you are getting the first available email address. Whether that is the bounced email address remains to be seen, because some bouncebacks list both the intended (failed) recipient and the sender's email addresses.

Issue 1:
The reason your code points to the default Inbox is because you are using the GetDefaultFolder Method:

[VBA]olNS.GetDefaultFolder(olFolderInbox).Folders("Test")[/VBA]

Use the Folders Collection to walk down the non-default folder hierarchy, like this:

[VBA]olNS.Folders("Archive E-Mails").Folders("Inbox").Folders("Mail Failures")[/VBA]

Issue 2:
Try stepping through the code.

Issue 3:

Change this line:

[VBA]xlApp.Workbooks.Add[/VBA]

to

[VBA]xlApp.Workbooks.Open (your filename here)[/VBA]

JP2112,

I made the code changes you recommended. I also added a line to mark the mail item as unread.

Previous:
[VBA]
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = Item.Body
Set olMatches = regEx.Execute(strBody)
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
End If
Next
[/VBA]

Current:
[VBA]
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = Item.Body
Set olMatches = regEx.Execute(strBody)
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
Item.UnRead = False
End If
Next
[/VBA]

I used "Step Into" to run each line one by one. I get to the loop and it does just that....It loops, and each time the unread count goes down by one. I do not know how to break out of the loop to continue with the rest of the code. I also notice that it is not starting with the youngest mail item. It starts about 1/16th of the way down the list each time. I don't know if this info is useful or not.

Here is the problem. After testing it seems that it is finding the proper folder and running through the loop, so I try running the macro (F5). As soon as I do the cursor changes to the hour glass, unread item count does not change, and Outlook becomes unresponsive. I then have to manually shut down and restart Outlook. I am now very confused and have no idea what to do.

Thank you and anyone else for helping. I have another mass mailer in a week and I have to get these addresses removed from our database.

Joshua

I forgot to post the fully revised code so here it is:

[VBA]
Sub badAddress()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim regEx As Object
Dim olMatches As Object
Dim strBody As String
Dim bcount As String
Dim lFirstPos As Long
Dim lLastPos As Long
Dim badAddresses 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.Folders("Archived E-Mail").Folders("Inbox").Folders("Mail Failures")
Set regEx = CreateObject("VBScript.RegExp")

'define regular expression
regEx.Pattern = "[\_]*([a-z0-9]+(\.|\_*)?)+@([a-z][a-z0-9\-]+(\.|\-*\.))+[a-z]{2,6}"
regEx.IgnoreCase = True
regEx.Multiline = True

' set up size of variant
bcount = olFolder.Items.Count
ReDim badAddresses(1 To bcount) As String

' initialize variant position counter
i = 0

' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = Item.Body
Set olMatches = regEx.Execute(strBody)
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
Item.UnRead = False
End If
Next

' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc

Set xlwkbk = xlApp.Workbooks.Open("My Folder Path Goes Here.")
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(badAddresses) + 1).Value = xlApp.Transpose(badAddresses)
xlApp.Visible = True
xlApp.ScreenUpdating = True

ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set badAddresses = 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
[/VBA]

I have found out why my script freezes and I have to force quit Outlook. The index of the items in the folder do not run from 1 to 10. For example, the first email in the folder might have an index of 7. That means this is the actual pattern of the indexes; 7,8,9,10,1,2,3,4,5,6. The loop will still start with index 1 and try to go to index 10, but it will freeze once it tries to parse the body on index 7. The strBody variable still loads the body from index 7.....I don't have a clue at this point. I know when the indexes coincide perfectly from top to bottom and 1 to 10, the script runs perfectly.

NOTE: The index numbers above are strictly for example. I have total of 3,137 emails.

Updated Code w/error notes
[VBA]
Option Explicit
Sub badAddress()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Item As MailItem
Dim regEx As Object
Dim olMatches As Object
Dim strBody As String
Dim bcount As String
Dim badAddresses 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.Folders("Archived E-Mail").Folders("Inbox").Folders("Mail Failures")
Set regEx = CreateObject("VBScript.RegExp")
'define regular expression
regEx.Pattern = "[\_]*([a-z0-9]+(\.|\_*)?)+@([a-z][a-z0-9\-]+(\.|\-*\.))+[a-z]{2,6}"
regEx.IgnoreCase = True
regEx.Multiline = True
' set up size of variant
bcount = olFolder.Items.Count
ReDim badAddresses(1 To bcount) As String
' initialize variant position counter
i = 0
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = olFolder.Items(i).Body
Set olMatches = regEx.Execute(strBody) 'FREEZES HERE WHEN THE INDEX NUMBER RETURNS TO THE START OF THE FOLDER
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
Item.UnRead = False
End If
Next Item
' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc
If Not IsFileOpen("myxlsfile.xls") Then
Set xlwkbk = xlApp.workbooks.Open("myxlsfile.xls")
End If
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(badAddresses) + 1).Value = xlApp.Transpose(badAddresses)
xlApp.Visible = True
xlApp.ScreenUpdating = True
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set badAddresses = 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

'Thanks to xld for the following function vbaexpress forums.
Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long

On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0

Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select

End Function
[/VBA]

I hope I was detailed enough with my explaination. Someone please help me. PLEASE!!!!!!!!!!!!!!!! I have been working on this for almost a month now.

Thanks,

Joshua

I ran your code and Outlook also froze (it went to 95% CPU) on this line:

Set olMatches = regEx.Execute(strBody) 'FREEZES HERE WHEN THE INDEX NUMBER RETURNS TO THE START OF THE FOLDER

So I suspect there is something wrong with your regular expression to catch email addresses. Sure enough, when I used the one from http://www.regular-expressions.info/...ddy/email.html, i.e.:

regEx.Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"

The code ran without problems.

No idea what you mean by "index of the items in the folder do not run from 1 to 10". Are you talking about the 'i' variable in your For Next loop? That will always go from 1 to n where n is number of emails in olFolder.items (i.e. olFolder.items.count).

Thanks for the reply. The code works just fine for me also.....when certain criteria is met. Yes, the index of the mailitem is referenced using the "i" variable. Search google for "outlook vba mailitem" and the first result will give you more details. I would include a link but I have not posted enough times yet.

[vba]
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.Folders("Archived E-Mail").Folders("Inbox").Folders("Mail Failures")
Set Item = olFolder.Items(2)
Item.Display
[/vba]
The code above should open the second email in the folder by referencing its index. This is where my problem occurs. Index #1 is not always the first email in the folder. The index numbering will still run consecutively but once it reaches the end of the folder it starts back at the top. View examples below.

Ex.A: Fails at index 7 but Starts at index 1
Start of Folder
email 1 - index 7
email 2 - index 8
email 3 - index 9
email 4 - index 10
email 5 - index 1
email 6 - index 2
email 7 - index 3
email 8 - index 4
email 9 - index 5
email 10 - index 6
End of Folder


Ex.B: Works Great
Start of Folder
email 1 - index 1
email 2 - index 2
email 3 - index 3
email 4 - index 4
email 5 - index 5
email 6 - index 6
email 7 - index 7
email 8 - index 8
email 9 - index 9
email 10 - index 10
End of Folder

I added a msgbox at different stages of the loop to test each variable. I also marked all items as unread and added [vba]Item.UnRead = False[/vba] just before it looped to the next item. This showed me where the looped started and failed in the folder. I then used the script above to test each mailitem's index number. This is when I noticed that ex. A always failed and ex. B worked like a champ. To take it one step further I added a msgbox to test the strBody variable. When it came around to index 7, the strBody variable did contain the body string and it froze once it tried to parse to string. I assumed something in the body was conflicting with the regEx, so I moved items with index 1 - 6 to another folder leaving only first four items. Again, I used the script above to see if 7 - 10 became 1 - 4 and they did. Re-ran my primary script and it worked perfectly. It parsed the "problem" email plus all the rest with no issues. I am no expert, but I do not know how the regEx would be causing this issue. Again, I am no expert.

I do know that everytime the mailitem index are like ex. A, it always freezes on the mailitem that returns to the top of the folder. This is the line of code that freezes:

[vba]
Set olMatches = regEx.Execute(strBody)
[/vba]

I am sorry if I am not being clear. I do not know any other way to explain it. I do know that I have done alot of testing and if you can recreate the out of order indexes it will freeze as stated above.

Is there any way to reset the mailitem index to match the order of emails in the folder??? I think that would fix all my problems. I spent many hours searching could not find anything that resembled this problem.

Thank you again for your help,

Joshua


PS - The index counts above are examples only. They do not represent the actual amount of emails I am in need of parsing.

@ Crocus Crow

I did change the regEx to the one you suggested and five minutes later there is my excel file with all 3,137 bad email addresses. You are the freaking man. I still do not know why the other one would cause it to fail when the conditions were as stated above, but it works now and I don't care.

Fully Functioning Script - Marks items as read when completed.
[vba]
Option Explicit
Sub badAddress()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Item As MailItem
Dim regEx As Object
Dim olMatches As Object
Dim strBody As String
Dim bcount As String
Dim badAddresses 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.Folders("Archived E-Mail").Folders("Inbox").Folders("Mail Failures")
Set regEx = CreateObject("VBScript.RegExp")
'define regular expression
regEx.Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
regEx.IgnoreCase = True
regEx.Multiline = True
' set up size of variant
bcount = olFolder.Items.Count
ReDim badAddresses(1 To bcount) As String
' initialize variant position counter
i = 0
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
i = i + 1
strBody = olFolder.Items(i).Body
Set olMatches = regEx.Execute(strBody)
If olMatches.Count >= 1 Then
badAddresses(i) = olMatches(0)
Item.UnRead = False
End If
Next Item
' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc
If Not IsFileOpen("YourExcelFileHere.xls") Then
Set xlwkbk = xlApp.workbooks.Open("YourExcelFileHere.xls")
End If
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(badAddresses) + 1).Value = xlApp.Transpose(badAddresses)
xlApp.Visible = True
xlApp.ScreenUpdating = True
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set badAddresses = 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 IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long

On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0

Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select

End Function

[/vba]


Thank you everyone so much for all your help!!!!!!!!!!!!

Joshua

Hi,

I know this is a solved and old post. However, I am having this error when I try running the code in Excel:

Quote:

---

Compile Error:

User-defined type not defined

---

I can't figure out what seems to be the problem. Any advise is appreciated.

Run the code from Outlook not Excel

Hi

when I use this last code from Joshua, I get an error 53. It does not find my excel sheet to put the email addresses in. But the name of the excel file is correct. What could be the reason for this? Do I need to put the excel sheet in a specific location so that the script does find it?

Thanks in advance

do you give the full path to the excel file?

Quote:

---

Originally Posted by westconn1

do you give the full path to the excel file?

---

This is my code regarding the excel name and path:

Code:

---


...
Next Item
' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc
If Not IsFileOpen("liste_bounced_emails.xls") Then
Set xlwkbk = xlApp.workbooks.Open("liste_bounced_emails.xls")
End If

....

---

yes, you need to give full path to excel file, not just filename

Quote:

---

Originally Posted by westconn1

yes, you need to give full path to excel file, not just filename

---

How do I do this in vba language, if the file is on my desktop?

Code:

---

Set xlwkbk = xlApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\liste_bounced_emails.xls")

---

you also need to change it in isfileopen as that function is generating the error 53

Quote:

---

Originally Posted by westconn1

you also need to change it in isfileopen as that function is generating the error 53

---

H

thank you all for your help. That worked now perfectly!

But now something strange is happening: I used the exact same code now for a different email folder. I want to do the exact same thing, just with a different outlook folder. Same excel sheet (which is now empty) etc.

So I changed the name of the outlook folder. The vba code also finds this outlook folder. But suddenly I get an error 13 "type mismatch".

When I click on debug, it highlight me the "Next Item" in the line "Next Item" in the first line where it wants to go to excel:

Code:

---

...
Next Item
' write everything to Excel
Set xlApp = GetExcelApp
If xlApp Is Nothing Then GoTo ExitProc
If Not IsFileOpen(Environ("USERPROFILE") & "\Desktop\liste_bounced_emails.xlsx") Then
Set xlwkbk = xlApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\liste_bounced_emails.xlsx")
End If
 
....

---

I do not understand this. It is the exact same code, same excel sheet etc. Why there is now an error, what worked perfectly 5 minutes ago? In this folder, there are over 2400 bounced emails.

What could be the reason for this and how can I fix this?Attachment 11588

Quote:

---

Originally Posted by beginner5

So I changed the name of the outlook folder. The vba code also finds this outlook folder. But suddenly I get an error 13 "type mismatch".

---

Same thing happened to me but I figured out that not everything in my folder was a mailitem so I changed…

Dim Item As MailItem

to

Dim Item As Object

and now it works!

Quote:

---

Originally Posted by fokrow

Same thing happened to me but I figured out that not everything in my folder was a mailitem so I changed…

Dim Item As MailItem

to

Dim Item As Object

and now it works!

---

Thank you very much! This was the reason for my error 13. Now it works!