简体   繁体   中英

Outlook VBA - move mail when assigned to a category

I would like to move emails to a sub-folder of my inbox when I assign it a category

I found the following code from Extended Office but it does not work. It is supposed to move mail to a subfolder with the same name as the category and create a folder if it does not exist.

I have enabled macros in Outlook's security settings and inserted some message box alerts to confirm that does in fact run.

The code is in ThisOutlookSession

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

Private Sub Application_Startup()

    MsgBox "Macros are working"

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

Private Sub xInboxItems_ItemChange(ByVal Item As Object)

MsgBox "Item Changed"

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
End Sub

I don't know exactly why but this suddenly started working today, I had restarted Outlook several times before but after I needed to force close Outlook this morning it started working. (I'm not even sure if it started working immediately because of the restart or if it was a short time afterwards triggered by something else)

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM