soccerjon1013
New Member
- Joined
- Apr 16, 2012
- Messages
- 48
I get e-mails through out the day that are subject "AUP Suspension of account : email@domain.com/net" and am trying to have it take the e-mail address from the body, and paste it on the bottom like of my excel document and getting this error. I would love any idea on how to fix it and if it's possible to get it to capture the date it was received also.
Code:
Option Explicit
Sub AUPCopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 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
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\\shedevil\tss\tierii\suspended email\aup contact list\2015\2015.xls"
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
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "ˆ([\w-]+\.)*[\w-]+@([\w-]+\.)+[a-z]{2,4}$"
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
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
></o
