Copy email to excel runtime error 5020

Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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))

End If

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

xlWB.Close 1
If bXStarted Then
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub]
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.)
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
It looks like the problem is with the pattern - you have an extra \
.Pattern = "((Vote With\s*)\w*\)\s*(\w*)\s*(\w*)\s*"
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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.

Similar threads