Consulting

Results 1 to 2 of 2

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

  1. #1
    VBAX Newbie
    Joined
    Dec 2020
    Posts
    1
    Location

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

    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!


    PrivateWithEventsxInboxFld AsOutlook.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.Categories)
            xMailItem.Move xTargetFld
        End If
    End If
    EndSub

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •