如何通过子文件夹名称自动分类Outlook共享收件箱内的邮件

前置操作步骤 #

打开Outlook VBA编辑器（快捷键Alt+F11），右键点击左侧项目栏的Project > 插入 > 类模块，将新插入的类模块重命名为FolderItemsWatcher。 #

完整代码 #

类模块 FolderItemsWatcher 代码 #

Public WithEvents FolderItems As Outlook.Items

Private Sub FolderItems_ItemAdd(ByVal Item As Object)
    Dim Cats() As String
    Dim i As Long
    Dim Exists As Boolean
    Dim CategoryName As String
    Dim curFolder As Outlook.MAPIFolder
    
    ' 仅处理邮件类型对象
    If TypeName(Item) <> "MailItem" Then Exit Sub
    
    ' 获取邮件所在文件夹
    Set curFolder = Item.Parent
    ' 生成对应层级的分类名
    CategoryName = GetFolderCategoryName(curFolder)
    
    ' 跳过收件箱根目录邮件
    If CategoryName = "" Then Exit Sub
    
    ' 检查当前邮件是否已添加该分类
    If Len(Item.Categories) > 0 Then
        Cats = Split(Item.Categories, ";")
        For i = 0 To UBound(Cats)
            If Trim(LCase$(Cats(i))) = LCase$(CategoryName) Then
                Exists = True
                Exit For
            End If
        Next
        
        If Not Exists Then
            Item.Categories = Item.Categories & ";" & CategoryName
            Item.Save
        End If
    Else
        Item.Categories = CategoryName
        Item.Save
    End If
    
    ' 自动创建不存在的分类
    Call CheckAndCreateCategory(CategoryName)
End Sub

ThisOutlookSession 代码 #

Private WatcherCollection As Collection

Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    
    Set Ns = Application.GetNamespace("MAPI")
    ' ===== 共享收件箱替换提示 =====
    ' 若使用共享收件箱，将下一行替换为：
    ' Set Inbox = Ns.Folders("共享邮箱的完整显示名称").Folders("收件箱")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
    ' ===========================
    
    Set WatcherCollection = New Collection
    ' 递归注册所有子文件夹的新邮件事件监听
    Call RegisterAllFolders(Inbox)
End Sub

' 递归遍历所有子文件夹，添加事件监听
Private Sub RegisterAllFolders(ByVal ParentFolder As Outlook.MAPIFolder)
    Dim subFolder As Outlook.MAPIFolder
    Dim Watcher As FolderItemsWatcher
    
    ' 注册当前文件夹监听
    Set Watcher = New FolderItemsWatcher
    Set Watcher.FolderItems = ParentFolder.Items
    WatcherCollection.Add Watcher
    
    ' 递归处理所有子文件夹
    For Each subFolder In ParentFolder.Folders
        Call RegisterAllFolders(subFolder)
    Next
End Sub

' 根据文件夹层级生成对应分类名
Function GetFolderCategoryName(ByVal curFolder As Outlook.MAPIFolder) As String
    Dim Inbox As Outlook.MAPIFolder
    Dim pathParts() As String
    Dim i As Long
    
    Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    ' ===== 共享收件箱替换提示 =====
    ' 若使用共享收件箱，将上一行替换为：
    ' Set Inbox = Application.GetNamespace("MAPI").Folders("共享邮箱的完整显示名称").Folders("收件箱")
    ' ===========================
    
    ' 收件箱根目录不生成分类
    If curFolder.EntryID = Inbox.EntryID Then
        GetFolderCategoryName = ""
        Exit Function
    End If
    
    ' 从当前文件夹向上遍历到收件箱，收集文件夹名称
    Do Until curFolder.EntryID = Inbox.EntryID
        ReDim Preserve pathParts(i)
        pathParts(i) = curFolder.Name
        i = i + 1
        Set curFolder = curFolder.Parent
    Loop
    
    ' 反转名称数组，拼接为「一级文件夹 - 二级文件夹」格式
    GetFolderCategoryName = Join(ReverseArray(pathParts), " - ")
End Function

' 数组反转工具函数
Function ReverseArray(arr As Variant) As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    
    j = UBound(arr)
    For i = 0 To (UBound(arr) \ 2)
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
        j = j - 1
    Next
    ReverseArray = arr
End Function

' 检查分类是否存在，不存在则自动创建
Sub CheckAndCreateCategory(CategoryName As String)
    Dim cate As Outlook.Category
    Dim exists As Boolean
    
    For Each cate In Application.Session.Categories
        If LCase(cate.Name) = LCase(CategoryName) Then
            exists = True
            Exit For
        End If
    Next
    
    If Not exists Then
        ' 可自定义分类颜色，替换olCategoryColorNone为指定的olCategoryColor常量即可
        Call Application.Session.Categories.Add(CategoryName, olCategoryColorNone)
    End If
End Sub

生效配置说明 #

• 代码调整完成后，重启Outlook即可自动生效
• 所有移入对应文件夹的邮件会自动添加对应层级的分类，无需手动创建规则或分类
• 若需要修改分类拼接格式，只需调整GetFolderCategoryName函数中的拼接逻辑即可

内容的提问来源于stack exchange，提问作者Roger Adel