0
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.
Sorry, but doesn't
If Not IsFileOpen(Environ("USERPROFILE") & "\Desktop\email_output.xls") Then Set xlwkbk = xlApp.workbooks.Open(Environ("USERPROFILE") & "\Desktop\email_output.xls") End If
take care of this possibility? And if so, wouldElse EndProc
be sufficient? – JaredT – 2016-07-28T19:29:03.853An "If" is a fork. If the object only gets set on one side of the fork, then there exists the possibility it never gets set. The line immediately after the "if" block throws the error. Since only two objects are referenced, and one of them is being set at that moment, we must concluded the object variable not set is
xlwkbk
. During execution,if Not (IsFileOpen())
must evaluate totrue
for the workbook object to be set properly. If it does not (such as when the file is open {Not True = False
}) then it never gets set. – Yorik – 2016-07-28T20:19:18.363I see. I've still got some learnin' to do. Turns out closing Excel made the macro work as intended (perhaps sub-optimally). Thanks for the info! – JaredT – 2016-07-28T23:18:45.823