VBA Function to parse email body for email address, write to excel
I have a requirement such that I need a function to iterate through all emails in an Outlook (2010) folder and grab an email address from the body of the email. The emails are found from Inbox \ Online Applicants \ TEST CB FOLDER
There will be only one email address in the body. This email then should be written to an excel file email_output.xls found on the desktop.
From this forum thread I have found and slightly altered the final macro to match my needs as best I could (only have cursory knowledge of VBA):
Option Explicit
Sub badAddress() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim olFolder As Outlook.MAPIFolder Dim Item As Object 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.GetDefaultFolder(olFolderInbox).Folders("Online Applicants").Folders("TEST CB FOLDER") 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(Environ("USERPROFILE") & "\Desktop\email_output.xls") Then Set xlwkbk = xlApp.workbooks.Open(Environ("USERPROFILE") & "\Desktop\email_output.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 After working through a few other errors that I could manage, the error object variable or with block variable not set occurs at Set xlwksht = xlwkbk.Sheets(1) (Line 46). The variables appear to be assigned properly and the spreadsheet definitely exists, properly named, on the desktop.
1 Answer
xlwkbk is not guaranteed to be set: you only set the object in the case of the File is Not (Not Open). You need an "else clause".
Instead of negating the FileIsOpen() test, just use the result directly.
Such as:
If FileIsOpen() then 'Do stuff for when file is open, such as test for the proper worksheet being active set worksheet to active sheet
else 'Open the worksheet like you have in example set worksheet by opening worksheet
endif
