Those dam categorys.

[maxwello]

Hi,
I have the below code that sends automated chasers and files emails after a certain time that are in my inbox.

What I would like to do now is only apply this macro to specific emails that have a certain category applied to them.

Is this possible?

Any assistance would be greatly appreciated.

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
 '***********************************************************************
 'Set email folders
    Set OutApp = New Outlook.Application
    Set oMAPI = OutApp.GetNamespace("MAPI")
    Set oParentFolder = oMAPI.Folders("my inbox)'Set mail box where the emails are
    Set f = oParentFolder.Folders("Inbox")
    Set g = oParentFolder.Folders("Inbox").Folders("No Reply Received")
'************************************************************************
  For eindex = f.Items.Count To 1 Step -1
    Select Case Now - f.Items(eindex).SentOn
            Case Is > 7 + IIf(Weekday(Date) > 0, 2, 0) ' Move Emails over 5 days to No Reply Recieved
                    f.Items(eindex).Move g
  '**********************************************************************
            Case Is > 5 + IIf(Weekday(Date) > 1, 2, 0) ' Send final chaser for all emails over 4 days
                Set Original = f.Items(eindex)
                Set r = Original.ReplyAll
                    r.Attachments.Add Original
                    r.SentOnBehalfOfName = "test"
                    r.CC = "test" & ""
                    r.Subject = "Urgent Chaser   -   " & f.Items(eindex).Subject
                    r.Body = "Please provide a response to the attached email within 24hrs or the request/action will be archived due to no response."
                    r.Display ' Change to send
 '**********************************************************************
            Case Is > 2 + IIf(Weekday(Date) > 3, 2, 0) ' Send initial chaser for all emails over 2 days
                Set Original = f.Items(eindex)
                Set r = f.Items(eindex).ReplyAll
                    r.Attachments.Add Original
                    r.SentOnBehalfOfName = "test"
                    r.CC = "Test"
                    r.Subject = "Urgent Chaser   -   " & f.Items(eindex).Subject
                    r.Body = "Please provide a response to the attached email." '& f.Items(eindex).Body
                    r.Display ' Change to Send
           End Select
        Next
End Sub