Hi Diane,
Thank you very much for helping me.
I have tried below code but I get an Array Index Out of Bounds error when a new message arrives in the shared Inbox.
It looks like following row is causing the error : Set oMail = ActiveExplorer.Selection(1)
Could you perhaps instruct me how I can solve get around this error?
I used following code:
Public WithEvents objItems As Outlook.Items
Sub MyBlue()
StrCat = "Erdal"
Application_Startup
End Sub
Private Sub Application_Startup()
Dim myRecipient As Recipient
Dim objNameSpace As NameSpace
Dim inbox As Folder
Set objNameSpace = Application.GetNamespace("MAPI")
Set myRecipient = objNameSpace.CreateRecipient("
shared@mail.com")
myRecipient.Resolve
If myRecipient.Resolved Then
Set inbox = objNameSpace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set objItems = inbox.Items
End If
End Sub
' Private Sub SetCategory()
Private Sub objItems_ItemAdd(ByVal Mail As Object)
' Dim Mail As Object
' Set Mail = Application.ActiveExplorer.Selection.Item(1)
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("
shared@mail.com")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set newINFolder = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
End If
Debug.Print Mail.Categories
arr = Split(Mail.Categories, ",")
If UBound(arr) >= 0 Then
' Check for Category
For i = 0 To UBound(arr)
If Trim(arr(i)) = StrCat Then
' remove it
arr(i) = ""
Mail.Categories = Join(arr, ",")
' Category Removed, exit
Exit Sub
End If
Next
End If
' Category not found, add it
Mail.Categories = StrCat & "," & Mail.Categories
DemoSetAlwaysAssignCategories
Mail.Save
End Sub
Sub DemoSetAlwaysAssignCategories()
Dim oMail As Outlook.mailItem
Dim oConv As Outlook.Conversation
Dim oStore As Outlook.Store
' Get the item displayed in the Reading Pane.
Set oMail = ActiveExplorer.Selection(1)
Set oStore = oMail.Parent.Store
If oStore.IsConversationEnabled Then
Set oConv = oMail.GetConversation
If Not (oConv Is Nothing) Then
Dim oFolder As Outlook.Folder
oConv.SetAlwaysAssignCategories StrCat, oStore
End If
End If
End Sub
As you might have noticed above I have pointed to the Namspace and object owner twice, not sure if it's correct way to doing it.
In addition I don't want the macro to remove previous marked Categorys, just continue marking the same category as previous marked category in the conversation.
Do I need to Always have the "Show as conversation" toggled on in Outlook to have the macro working?
Thank you very much in advance.