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

[westconn1]

try like

For eindex = f.Items.Count To 1 Step -1
if f.items(eindex).category = "mycategory" then
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
end if
Next

[maxwello]

Hi,
I had tried this but I keep getting an error message called "Run-time error '438': Object doestn support this property or method", any ideas what needs to be done.

Dim eindex As Integer

Regards
Oliver

[westconn1]

Run-time error '438'on which line?

try
If instr(f.items(eindex).categories, "mycategory") > 0 Then

[maxwello]

Hi,

The Run time error occured on the line
If f.Items(eindex).Category = "mycategory" Then and now if I amned the code as per your last post I get "Compile error: User-defined type not defined" at line: Dim eindex As Integerc.

Thanks for your assistance.

Regards
Oliver

[westconn1]

User-defined type not defined" at line: Dim eindex As Integerc.looks like you got a random keystroke on that line, see you original post, remove the last character

[maxwello]

looks like you got a random keystroke on that line, see you original post, remove the last character

Perfect thank you for your assistance.

[maxwello]

Perfect thank you for your assistance.

Hi,
I need some more help..:)

I have the below code that monitors emials coming into the inbox and if the subjects match it did move the emails to another folder. However I would now like it to remove the category that has been assigned to the original email. How can I do this as I have tried loads of ways and I cannot get it to work.


Private Sub Application_NewMail()
Dim i As MailItem, a As Attachment, s As MailItem
Dim e As Outlook.MailItem
Dim h As Outlook.MailItem
Dim OutApp As New Outlook.Application
Dim oMAPI As Outlook.NameSpace
Dim oParentFolder As Outlook.MAPIFolder
Dim oFolder As Outlook.folder
Dim olObject As Object


Set oMAPI = OutApp.GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders("Mailbox - Maxwell, Oliver: Ops Client Services (LDN)") 'Set mail box where the emails are
Set f = oParentFolder.Folders("Inbox")
Set g = oParentFolder.Folders("Inbox").Folders("waiting for reply")
Set olObject = f.Items.GetFirst()

For Each e In f.Items
If InStr(olObject.ConversationTopic, e.ConversationTopic) > 0 Then ' match
Set f.Items.Categories.Remove = ""
Exit For ' stop looking
End If
Next e
End Sub

[westconn1]

have you tried
fitems.categoies = ""

[maxwello]

have you tried
fitems.categoies = ""

Hi,
Yes and I get the "Run-time error '438': Object doesnt support this property or method.

I really dont get it.

Regards
Oliver

[westconn1]

on rereading your code
try
e.categories = ""

[maxwello]

on rereading your code
try
e.categories = ""

That does work but not in the way I need it to, maybe there is a smarter way of doing it.

What I want it to do is monitor the emails coming in if one matches any of the subject lines of the emails that are categorized as "Test" then the MACRO will remove the category test from the original email as this will be applied after it was originally sent to the recipient so the incoming email will not have a category applied.

Do you have any bright ideas?

[westconn1]

if you only want to remove a single category (test)
try

e.categories = replace(e.categories, "Test ", "")

i guess you would also need to save the email after changing the categories

other than that i am not quite sure what you want to change

[maxwello]

Hi,
Thanks again for all your help, however I do have one last problem.

Currently the below script is triggered when a new email is sent to my personal inbox. How can I script it so that the code is triggered when a new email is sent to a group inbox?


Private Sub Application_NewMail()
Dim i As MailItem, a As Attachment, s As MailItem
Dim e As Outlook.MailItem
Dim h As Outlook.MailItem
Dim OutApp As New Outlook.Application
Dim oMAPI As Outlook.NameSpace
Dim oParentFolder As Outlook.MAPIFolder
Dim oFolder As Outlook.folder
Dim olObject As Object
Set oMAPI = OutApp.GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders("Mailbox - Ecommerce Onboarding EMEA") 'Set mail box where the emails are
Set f = oParentFolder.Folders("Inbox")
Set olObject = f.items.GetFirst()

For Each e In f.items
If InStr(olObject.ConversationTopic, e.ConversationTopic) > 0 Then ' match
If InStr(e.Categories, "Pending Sales Response - Macro") > 0 Then
e.Categories = Replace(e.Categories, "Pending Sales Response - Macro", "")
e.Save
Exit For ' stop looking
End If
End If
Next e
End Sub

[westconn1]

i have no availability to group mailbox, so difficult to help with that

it would be possible to have an object of mailitems (the content of group mailbox) with events
then use the event of when a new item is added to the mailitems collection

i can not test how to return a reference to a group mailbox, except when it is already open in outlook, then it is activeinspector.currentfolder

[maxwello]

i have no availability to group mailbox, so difficult to help with that

it would be possible to have an object of mailitems (the content of group mailbox) with events
then use the event of when a new item is added to the mailitems collection

i can not test how to return a reference to a group mailbox, except when it is already open in outlook, then it is activeinspector.currentfolder

Hi,
I know you cant test it but could you give me some guidance on how to code this?

thanks

[westconn1]

Public WithEvents itms As Items

Sub initiate()
Set itms = ActiveExplorer.CurrentFolder.Items
End Sub
you would normally initiate in application.startup, but i can not help with that as you would have to switch to the group mailbox before initiating

public withevents would have to be in thisoutlooksession or a class module

NOTE this will only run while your outlook is open, mails that arrive while your outlook is not running will not be processed




Private Sub itms_ItemAdd(ByVal Item As Object)
'process incoming items here
End Sub move all your code here to run when ever an arriving email item is added to the collection

alternatively run a sweep on all email items in the folder, arrived since last sweep
like once a day, or every hour

[maxwello]

Public WithEvents itms As Items

Sub initiate()
Set itms = ActiveExplorer.CurrentFolder.Items
End Sub
you would normally initiate in application.startup, but i can not help with that as you would have to switch to the group mailbox before initiating

public withevents would have to be in thisoutlooksession or a class module

NOTE this will only run while your outlook is open, mails that arrive while your outlook is not running will not be processed




Private Sub itms_ItemAdd(ByVal Item As Object)
'process incoming items here
End Sub move all your code here to run when ever an arriving email item is added to the collection

alternatively run a sweep on all email items in the folder, arrived since last sweep
like once a day, or every hour

[maxwello]

Is there anyway to set up a timer that runs the code every ten seconds, I know you can use the Calendar but thats not an option here is ther any other way to do it?

[westconn1]

tasks or calendar are the only methods i am aware of in outlook, most any code method will make outlook unresponsive while running
there is no application.ontime method in outlook

[skatonni]

See timer code here
http://stackoverflow.com/questions/12257985/outlook-vba-run-a-code-every-half-an-hour
http://stackoverflow.com/questions/23736851/outlook-vba-run-a-code-every-half-an-hour-with-outlook-2010-64-bits

[maxwello]

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