Copy email to excel runtime error 5020

[CindyT]

Hi there,
I pulled code added by Diane Poremsky from slipstick systems and made what I thought were the necessary changes(still learning vba) to copy an email body to excel. I get the runtime 5020 Application-defined or object-defined error. The code runs through opens the excel file and errors at 'If Reg1.Test(sText) Then'. It does seem to detect the email body text, but not sure where to go from here. If I need to add the folder object and/or what my issue is? Any help is greatly appreciated. Best, Cindy
Here is the code:


[ Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object



Set olItem = Application.ActiveExplorer().Selection(1)
enviro = CStr(Environ("USERPROFILE"))

strPath = "P:\Operations\Votes Log\TESTSchedule.xlsm"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0

Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Testing")


rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

sText = olItem.Body

Set Reg1 = CreateObject("VBScript.RegExp")


With Reg1
.Pattern = "((Vote With\s*)\w*\)\s*(\w*)\s*(\w*)\s*"
End With
If Reg1.Test(sText) Then


Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))



Next
End If

xlSheet.Range("B" & rCount) = vText



xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub]

 

[Diane Poremsky]

Did you set a reference to the Regular Expressions library?

 

[CindyT]

Did you set a reference to the Regular Expressions library?

If this is what you mean, yes. Does it need a higher priority? Sorry, I am not skilled enough in vba figure it out.

 

[Diane Poremsky]

Yes, that is what I meant. No, i don't think it needs to be higher priority. I'll test it later (I have a meeting starting soon.)

 

[Diane Poremsky]

It looks like the problem is with the pattern - you have an extra \
.Pattern = "((Vote With\s*)\w*\)\s*(\w*)\s*(\w*)\s*"

 

[CindyT]

Thanks for your reply. It is definitely the pattern and I made your change and no more error, but nothing populated. I was hoping you could help me with the pattern matching. I want to put the entire line into one cell and pull all the emails from my folder. The emails are always going to begin "((Vote With\s*)) but there are other words after that string. I pulled up Use a macro to copy data in Outlook email to Excel workbook but can't get the pattern I entered to work or all the messages from the folder. I think I need to change the pattern to something like .Pattern = "((Vote With\s*[\w*-\s*]*))" and to add a Dim FolderItem As Object. Definitely willing to research more or look at more solved cases but I definitely (greatly) appreciate your replies on this.
.