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._%-][email protected][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.

Replay

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

Category: microsoft excel Time: 2016-07-28 Views: 0

Related post

iOS development

Android development

Python development

JAVA development

Development language

PHP development

Ruby development

search

Front-end development

Database

development tools

Open Platform

Javascript development

.NET development

cloud computing

server

Copyright (C) avrocks.com, All Rights Reserved.

processed in 0.218 (s). 12 q(s)