Thanks you all for the assistance, below is the final code that will send out auto chasers for emails with a specific category and work out the number of working days and delete specific emails from the reply before sending.
Sub ApplicationReminder()
Dim m As Outlook.MailItem
Dim R As Outlook.MailItem
Dim eindex As Integer
Dim Original As Object
Dim OutApp As New Outlook.Application
Dim oMAPI As Outlook.NameSpace
Dim oParentFolder As Outlook.MAPIFolder
Dim oFolder As Outlook.folder
Dim workdays As Long
Dim recips As Outlook.Recipients
Dim i As Long
Dim t As Outlook.Recipient
Dim Endate As Variant
Dim test As String
Dim objItem As MailItem
Dim reps As String
Dim RemoveThis As VBA.Collection
Dim Recipients As Outlook.Recipients
Dim v As Long
Dim y As Long
Set RemoveThis = New VBA.Collection
Dim StartDate As Date
'*******************Set Email Folder****************************************************
'Set email folders
Set OutApp = New Outlook.Application
Set oMAPI = OutApp.GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders("Mailbox - ") 'Set mail box where the emails are
Set f = oParentFolder.Folders("Inbox")
'********************Works through emials with specific category****************************************************
For eindex = f.items.Count To 1 Step -1
If InStr(f.items(eindex).Categories, "Pending Response - Macro") > 0 Then
i = Now - f.items(eindex).SentOn
'**************************Works out the number of work days*******************
EndDate = Date
StartDate = f.items(eindex).SentOn
StartDate = Format(StartDate, "dd/mm/yyyy")
For i = StartDate To EndDate
EndDate = StartDate + i
If Weekday(EndDate) = 6 Then i = i + 2
days = days + 1
Next i
'*************************Select Statements for day age buckets******************************************************
Set objItem = f.items(eindex)
Select Case days
Case Is > 10 'Move Emails over 10 days to No Reply Recieved
f.items(eindex).Categories = Replace(f.items(eindex).Categories, "Pending Response", "No Response Received")
f.items(eindex).Save
Case Is = 6 ' Send final chaser for all emails over 6 days
Set Original = f.items(eindex)
Set R = f.items(eindex).ReplyAll
R.Attachments.Add Original
R.SentOnBehalfOfName = "Set email address"
R.CC = "Set email address" & ""
R.Subject = "Urgent Chaser 2 - " & f.items(eindex).Subject
R.Body = "Please provide a response to the attached email or the request/action will be archived due to no response."
'************Deletes the eCommerce Onboarding Email**************
RemoveThis.Add "/Set email address"
Set Recipients = R.Recipients
For v = Recipients.Count To 1 Step -1
Set t = Recipients.Item(v)
For y = 1 To RemoveThis.Count
If LCase$(t.Address) = LCase$(RemoveThis(y)) Then
Recipients.Remove v
Exit For
End If
Next
Next
'****************************************************************
R.Display ' Change to send
Case Is = 3 'Send initial chaser for all emails over 3 days
Set Original = f.items(eindex)
Set R = f.items(eindex).ReplyAll
R.Attachments.Add Original
R.SentOnBehalfOfName = "Set email address"
'r.CC = " " Can be set to cc Sales
R.Subject = "Urgent Chaser 1 - " & f.items(eindex).Subject
R.Body = "Please provide a response to the attached email." '& f.Items(eindex).Body
'************Deletes the eCommerce Onboarding Email**************
RemoveThis.Add "Set email address"
Set Recipients = R.Recipients
For v = Recipients.Count To 1 Step -1
Set t = Recipients.Item(v)
For y = 1 To RemoveThis.Count
If LCase$(t.Address) = LCase$(RemoveThis(y)) Then
Recipients.Remove v
Exit For
End If
Next
Next
'****************************************************************
R.Display ' Change to Send
End Select
End If
days = 0
Next
End Sub
Reply With Quote
Originally Posted by westconn1
