使用 Outlook VBA 为选定的电子邮件添加自动类别

Question

不幸的是，

我无法在 Outlook 2021 中成功自动化以下代码。

但是手动执行却运行成功。

有人可以为我提供解决方案吗？

非常感谢。

Public Sub MarkSelectedAsGreenCategory()
    Dim olItem As MailItem
    
    Dim newCategory As String
    newCategory = "Green category"
    
    Dim i As Integer
    
    For i = 1 To Application.ActiveExplorer.Selection.Count
        Set olItem = Application.ActiveExplorer.Selection(i)
        AddCategory olItem, newCategory
        Set olItem = Nothing
    Next
      
End Sub

Private Sub AddCategory(mailItem As mailItem, newCategory As String)
    Dim categories() As String
    Dim listSep As String

    ' Get the current list separator from Windows regional settings
    listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")

    ' Break the list up into an array
    categories = Split(mailItem.categories, listSep)

    ' Search the array for the new category, and if it is missing, then add it
    If UBound(Filter(categories, newCategory)) = -1 Then
        ReDim Preserve categories(UBound(categories) + 1)
        categories(UBound(categories)) = newCategory
        mailItem.categories = Join(categories, listSep)
    End If
End Sub

Answer 1

谢谢你们，你们太棒了：这是解决方案，对我有用。

特别感谢@0m3r和@niton。

Public WithEvents myOlExp As Outlook.Explorer

Public Sub Initialize_handler()
 
 Set myOlExp = Application.ActiveExplorer
 
End Sub

Private Sub myOlExp_SelectionChange()
    Dim olItem As mailItem
    
    Dim newCategory As String
    newCategory = "Green category"
    
    Dim i As Integer
    
    For i = 1 To Application.ActiveExplorer.Selection.Count
        Set olItem = Application.ActiveExplorer.Selection(i)
        AddCategory olItem, newCategory
        Set olItem = Nothing
    Next
End Sub

Private Sub AddCategory(mailItem As mailItem, newCategory As String)
    Dim categories() As String
    Dim listSep As String

    ' Get the current list separator from Windows regional settings
    listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")

    ' Break the list up into an array
    categories = Split(mailItem.categories, listSep)

    ' Search the array for the new category, and if it is missing, then add it
    If UBound(Filter(categories, newCategory)) = -1 Then
        ReDim Preserve categories(UBound(categories) + 1)
        categories(UBound(categories)) = newCategory
        mailItem.categories = Join(categories, listSep)
        mailItem.Save
    End If
End Sub