Auto categorize duplicate subjects

[codell911]

Currently using the following script to round robin assign incoming emails:

Dim i As Long
Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath("Mailbox - SATPD\Inbox").Items
Set objNS = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim strCat As String

On Error Resume Next

If Item.Class = olMail Then
Select Case i
Case 0
strCat = "Bob"
Case 1
strCat = "Larry"
Case 2
strCat = "Buddy"
Case 3
strCat = "Sue"

End Select

Item.Categories = strCat
Item.UnRead = True
Item.Save
Err.Clear
End If
i = i + 1
Debug.Print i
If i = 4 Then i = 0
End If

End Sub

Script works great! (thanks Diane)

What I want to add to it is add an IF condition where the script scans all incoming emails, and if it finds an incoming email with a subject that EXACTLY matches an email that has already been categorized to Bob, Larry, Buddy or Sue, categorize that new email to them as well. (i.e. if Bob has an email categorized to him with subject "Test 1234", then if a new emails comes in with subject "Test 1234", I would like that new email categorized to him and not be assigned "round robin".

Not to make it more complicated, but I also do want want that new email with the duplicate subject to count towards the "round robin". (i.e. email 1 goes to Bob, emails 2 comes in with a duplicate subject and goes to Larry who has an email with the same subject, if email 3 comes in without a duplicate subject, I want that to go to Larry as well since he is next in line for new emails after Bob)

Thanks for any help!

 

[codell911]

Correction to the last paragraph: I do NOT want that new email with the duplicate subject to count towards the "round robin"

 

[Diane Poremsky]

I have a macro at Use a Rule to delete older messages as new ones arrive that deleted old mail of the same subject when a new message arrives... bits of that could be merged with this to do what you want.

This should do the look up and categories part - put it at the top and it exists if a match is found. If the inbox has a lot of mail, find or restrict would be faster though. (I use it on an inbox with over 4000 messages and it was slow until i restricted the count to the 30 most recent messages. 30 met my needs for the typical 4 hours between automated messages - i could go a little higher without slowing it down.)

If the messages will be replies, you need to account for the "RE: " - using the conversation topic instead of subject is one that should work - or you can use subject with the mid or instr function.

If objVariant.ConversationTopic= Item.ConversationTopic

For intCount = objInbox.Items.Count To 1 Step -1
Set objVariant = objInbox.Items.Item(intCount)
If objVariant.MessageClass = "IPM.Note" Then
    If objVariant.Subject = Item.Subject And objVariant.SentOn < Item.SentOn Then
     item.categories = objVariant.categories
     item.save
    exit sub
     Else
    End If
End If
Next

I don't think you need the date check - there will either be matches or not.

 

[codell911]

Not getting any errors, but after modifying the script, it isn't catching the duplicates:

Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  Set olInboxItems = GetFolderPath("Mailbox - SATPD\Inbox").Items
Set objNS = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    Dim strCat As String
  
    On Error Resume Next
  
    If TypeOf Item Is Outlook.MailItem Then
    DuplicateSubjects Item
    End If
  
    If Item.Class = olMail Then
  
    Select Case i
     Case 0
          strCat = "Bob"
     Case 1
          strCat = "Larry"
     Case 2
          strCat = "Buddy"
     Case 3
          strCat = "Sue"
              
    End Select


      
    Item.Categories = strCat
            Item.Save
        Err.Clear
     End If
     i = i + 1
     Debug.Print i
     If i = 4 Then i = 0
   
End Sub

Private Sub DuplicateSubjects(Item As Outlook.MailItem)

    Dim objInbox As Outlook.MAPIFolder
    Dim intCount As Integer
    Dim objVariant As Variant

Set objInbox = Session.GetDefaultFolder(olFolderInbox)

For intCount = objInbox.Items.Count To 1 Step -1
Set objVariant = objInbox.Items.Item(intCount)
If objVariant.MessageClass = "IPM.Note" Then
    If objVariant.Subject = Item.Subject And objVariant.SentOn < Item.SentOn Then
     Item.Categories = objVariant.Categories
     Item.Save
    Exit Sub
     Else
    End If
End If
Next

Set objInbox = Nothing
End Sub

 

[codell911]

To clarify, I want to use this on a shared mailbox as part of the application startup script to monitor emails as they come in.........................

 

[Diane Poremsky]

I cannot copy lines on this tablet so i cant show you which line needs fixed, but if you are searching the same folder, you don't need to set a folder to search. You can use olinboxitems (which is set in startup) in place of objinbox.items.

 

[Diane Poremsky]

Back on my desktop... this has the changes you need to make. This line: Set objInbox = Session.GetDefaultFolder(olFolderInbox) was looking in your own inbox.

Private Sub DuplicateSubjects(Item As Outlook.MailItem)

    Dim intCount As Integer
    Dim objVariant As Variant

For intCount = olInboxItems.Count To 1 Step -1
Set objVariant = olInboxItems.Item(intCount)
If objVariant.MessageClass = "IPM.Note" Then
    If objVariant.Subject = Item.Subject And objVariant.SentOn < Item.SentOn Then
     Item.Categories = objVariant.Categories
     Item.Save
    Exit Sub
     Else
    End If
End If
Next

Set objInbox = Nothing
End Sub

 

[codell911]

Awesome. Thank so much Diane!

Once more question ......on Outlook startup, is there anyway to use the GetFolderPath function to monitor 2 different shared mailboxes and use 2 different scripts for each? Basically, I want to use 1 script to monitor incoming to shared mailbox "Mailbox - Test1\Inbox" and then use a different script to monitor incoming to shared mailbox "Mailbox - Test2\Inbox". Is that possible?

 

[Diane Poremsky]

Sure... you need to copy the relevant lines and use a different variable name - paste them right after the first one. The function is designed to work with any macro that calls it - i usually put it (and other functions) in a module named 'Functions' so i can easily see what i have available already.


Private WithEvents olInboxItems As Items
Private WithEvents olTest2InboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath("Mailbox - SATPD\Inbox").Items
Set olTest2InboxItems = GetFolderPath("Mailbox - ABCDE\Inbox").Items
Set objNS = Nothing
End Sub

Add a second sub:
Private Sub olTest2InboxItems_ItemAdd(ByVal Item As Object)
'do whatever
end sub

If both subs are doing the same thing, you could share them - except in your specific case, the duplicates macro is checking a specific folder (olInboxItems) - you'd need to set a public variable and pass the folder name to it in the itemadd macro before handing it off. Easy to do, but something to keep in mind when sharing macros.

Private Sub olTest2InboxItems_ItemAdd(ByVal Item As Object)
SharedSub Item
end sub

Private SharedSub (Item As Object)
' do whatever
end if

 

[codell911]

Diane,

So basically, things are humming along nicely based on your last post. Only issue I see is, on the incoming mail count, its combing the 2 mailboxes into 1 count instead of counting them separately.

Example:

1st email comes into Mailbox 1 and is assigned to Bob (who is 1st in line in Mailbox 1)
2nd email comes into Mailbox 1 and is assigned to Bill (who is 2nd in line in Mailbox 1)
1st email comes into Mailbox 2 and is assigned to Sue (who is 3rd in line in Mailbox 2; it has skipped over Mary and Tim who are 1st and 2nd in line to receive new emails from this box) - I want this email going to the 1st person in line in Mailbox 2

Thoughts?

 

[Diane Poremsky]

You need a second variable for the count -
Dim i As Long
Dim iA as long

 

[codell911]

All is working as intended. Thanks again. Youre the best!