如何为已发送邮件分配、修改、移除分类？Outlook自动跟进宏开发求助

完整实现代码 #

' 绑定收件箱物品集合和应用程序事件
Public WithEvents objInboxItems As Outlook.Items
Public WithEvents olApp As Outlook.Application

Private Sub Application_Startup()
    Set olApp = Outlook.Application
    ' 初始化收件箱物品监听
    Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

' 发送邮件时自动为带跟进标记的邮件添加蓝色分类
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class = olMail Then
        ' 判断邮件是否设置了任务跟进标记
        If Item.IsMarkedAsTask = True Then
            ' 此处分类名称可根据你Outlook本地的分类自定义修改
            Item.Categories = "蓝色类别"
            Item.Save
        End If
    End If
End Sub

' 收到新邮件时匹配对应已发送邮件，自动清除标记和分类
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim objSentItems As Outlook.Items
    Dim objVariant As Variant
    Dim i As Long
    Dim strSubject As String
    Dim dSendTime As Date
 
    Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
 
    If Item.Class = olMail Then
       For i = 1 To objSentItems.Count
           If objSentItems.Item(i).Class = olMail Then
              Set objVariant = objSentItems.Item(i)
              ' 跳过已经清除跟进标记的邮件，减少不必要的判断
              If objVariant.IsMarkedAsTask = False Then GoTo NextMail
              
              strSubject = LCase(objVariant.Subject)
              dSendTime = objVariant.SentOn
 
              ' 匹配回复主题
              If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
                 If Item.SentOn > dSendTime Then
                    With objVariant
                         .ClearTaskFlag
                         .ReminderSet = False
                         ' 清除分类
                         .Categories = ""
                         .Save
                    End With
                 End If
              End If
NextMail:
           End If
       Next i
    End If
End Sub

' 提醒触发时判断是否为未回复的跟进邮件，自动改为红色分类+通知
Private Sub olApp_Reminder(ByVal Item As Object, Cancel As Boolean)
    If Item.Class = olMail Then
        ' 判断是否是已发送文件夹的带跟进标记邮件
        If Item.Parent = Application.Session.GetDefaultFolder(olFolderSentMail) And Item.IsMarkedAsTask = True Then
            ' 修改为红色分类
            Item.Categories = "红色类别"
            Item.ReminderSet = False
            Item.Save
            ' 弹出自定义通知
            MsgBox "邮件《" & Item.Subject & "》已到跟进时间，仍未收到对方回复，请及时处理。", vbInformation, "邮件跟进提醒"
        End If
    End If
End Sub

注意事项 #

• 代码中的蓝色类别、红色类别需要和你Outlook中实际的分类名称保持一致，如果你自定义了分类名称，直接修改对应字符串即可。
• 首次使用需要按Alt+F11打开VBA编辑器，将代码粘贴到ThisOutlookSession模块中，运行Application_Startup过程，或者重启Outlook即可生效。
• 发送邮件前只需正常设置跟进标记和提醒时间，后续逻辑全部自动执行。

使用说明 #

• 带蓝色分类的已发送邮件：等待回复中，还未到跟进时间
• 带红色分类的已发送邮件：已到跟进时间仍未收到回复，需要手动跟进
• 收到对应回复后，邮件的跟进标记和分类会自动清除，无需手动操作

内容的提问来源于stack exchange，提问作者theodorik leao