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

Question

我正在尝试使用VBA为Outlook中选择的每封电子邮件添加一个类别。

问题是，下面的代码只将类别添加到第一封电子邮件中。

我正在使用Outlook 2016。

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_USERControl PanelInternationalsList")
' 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

ActiveInspector.CurrentItem上的类别更新将生成保存提示。

选择：

olItem.Save或mailItem.Save。

Answer 2

以下是删除类别的相应代码：

Public Sub RemoveCategory(mailItem As mailItem, oldCategory 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_USERControl PanelInternationalsList")
' Break the list up into an array
categories = Split(mailItem.categories, listSep)
' Search the array for the new category, and if it is present, then remove it
If UBound(Filter(categories, oldCategory, True, vbTextCompare)) <> -1 Then
categories = Filter(categories, oldCategory, False, vbTextCompare)
mailItem.categories = Join(categories, listSep)
End If
End Sub