Move Emails To Specified Folder After Assigning Certain Category - Shared Mailbox

[DPT989]

Hello,

I'm very new to outlook and VBA. I've found the code below which is working exactly how I want it - assign a category, the email gets moved real time to the associated folder within my inbox - if the folder does not exist, it makes one.

I want this code to function properly on a shared mailbox I am a part of as well - it is not part of my Microsoft account but I have full access to the mailbox. I need the same functionality - while in the inbox, assign a category and have it move to the corresponding subfolder within the shared mailbox's inbox.

Any help would be appreciated - as I said I'm very new to VBA but I can try to answer any questions!



Private WithEvents xInboxFld As Outlook.FolderPrivate WithEvents xInboxItems As Outlook.Items

Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub

Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categ ories)
xMailItem.Move xTargetFld
End If
End If
End Sub

[gmayor]

In theory at least, and based on your code, the following should work, and certainly the folder is created as required, but the Move command is not working in my installation, which may be a local issue
Change 'Display Name of Shared Account' to the name of that account as appropriate. There is no need to give Item another variable name.


Option Explicit
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.items
Private WithEvents shInboxFld As Outlook.Folder
Private WithEvents shInboxItems As Outlook.items


Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.items
Set shInboxFld = Outlook.Application.Session.Accounts.Item("Display Name of Shared Account").DeliveryStore.GetDefaultFolder(olFolderInbox)
Set shInboxItems = shInboxFld.items
End Sub


Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xFlds As Outlook.folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
xFlag = False
If Item.Categories <> "" Then
Set xFlds = xInboxFld.folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = Item.Categories Then
xFlag = True
Exit For
End If
Next
End If
If xFlag = False Then
xInboxFld.folders.Add Item.Categories, olFolderInbox
End If
Set xTargetFld = xInboxFld.folders(Item.Categories)
Item.Move xTargetFld
End If
End If
End Sub


Private Sub shInboxItems_ItemChange(ByVal Item As Object)
Dim shFlds As Outlook.folders
Dim shFld As Outlook.Folder
Dim shTargetFld As Outlook.Folder
Dim shFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
shFlag = False
If Item.Categories <> "" Then
Set shFlds = shInboxFld.folders
If shFlds.Count <> 0 Then
For Each shFld In shFlds
If shFld.Name = Item.Categories Then
shFlag = True
Exit For
End If
Next
End If
If shFlag = False Then
shInboxFld.folders.Add Item.Categories, olFolderInbox
End If
Set shTargetFld = shInboxFld.folders(Item.Categories)
Item.Move shTargetFld
End If
End If
End Sub