get e-mail address, copy to bottom row .pattern is set

[soccerjon1013]

I have e-mails that come in throughout the day and I'm having a hard time removing the address, and pasting it on the bottom line of an excel document. If it helps, before the e-mail address there are 7 spaces. I was able to compile the below code from digging around on the internet and forums, however I am unable to find this exact procedure, and lack the know how to correctly set this up. The e-mail format is:


Hello,

The following account has been suspended due to complaints received by recipients regarding the content of the messages having abusive spam behaviour and/or mass mailing patterns within the OpenSRS Hosted Environment.

This is due to repeat complaints from recipients and/or high volume outboundspam.

We have taken the following action:
* Placed this end user under AUP Violation
* Placed this end user on our internal abuse list

Please take the following actions:
* Inform the account owner of the reasons for suspension (provide evidence as needed)
* Take appropriate action to ensure this activity does not continue.
* Remove the AUP Violation flag or permanently disable the accountThe account in question is:

(8 spaces)blahblah@domain.(com or net)

IMPORTANT: If you determine that this account name is NOT related to repeat spammers, and is legitimate, please let us know ASAP, or as new accounts arecreated that have a similar pattern, they may also be suspended.

Thanks,



The vba I have so far is:

Option Explicit
Private Sub AUPCopyToExcel()
    Dim objInbox As Outlook.Folder
    Dim objNewMail As Outlook.MailItem
    Dim objRegEx As VBScript_RegExp_55.RegExp
    Dim colFoundWords As VBScript_RegExp_55.MatchCollection
    Dim objFoundWord As VBScript_RegExp_55.Match
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    
    ' Get Access to You Inbox
    Set objInbox = Outlook.Session.GetDefaultFolder(olFolderInbox)


    
    ' Look for the most recent Unread Item in your inbox
    Set objNewMail = objInbox.Items.GetLast
    
    ' Set up Regular Expressions to search for the email Address
    Set objRegEx = New VBScript_RegExp_55.RegExp
    
    Debug.Print objNewMail.Body
        
    ' Search for Matching Email Addresses
    With objRegEx
        .IgnoreCase = True
        ' Set Global to False to only find the first instance as there could be more than one if they sent the email
        ' and it turned it into a link
        .Global = False
        ' This pattern will look for you email address - see http://www.regular-expressions.info/email.html if you want to know more
      ' ******  Update this with the correct email domain
        .Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
        ' Run the Search
        Set colFoundWords = .Execute(objNewMail.Body)
    End With
    
    ' Make sure we found something.  We will work from just the first found instance.
    ' There may be more than one
    If colFoundWords.Count > 0 Then
    ' open excel, find last row, print
        
        
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim strPath As String
 Dim Reg1 As Object
 Dim M1 As Object
 Dim M As Object
        


'the path of the workbook
 strPath = "\\shareddrive\tss\tierii\2015.xls"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     Set xlApp = CreateObject("Excel.Application")
       bXStarted = True
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
     rCount = rCount + 1
     
     xlSheet.Range("A" & rCount) = (colFoundWords.Item(0))
     xlSheet.Range("K" & rCount) = "objNewMail.Body"
     
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     
    ' Clean up
     Set M = Nothing
     Set M1 = Nothing
     Set Reg1 = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing


    Set objInbox = Nothing
    Set objNewMail = Nothing
    Set objRegEx = Nothing
    Set colFoundWords = Nothing
    Set objFoundWord = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
        
End Sub