使用 Outlook VBA 为所有选定的电子邮件添加类别
Add a category for all selected emails using Outlook VBA
我正在尝试使用 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_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
更新 ActiveInspector.CurrentItem
上的类别会生成保存提示。
选择:
olItem.Save
或 mailItem.Save
在您方便的时候。
我正在尝试使用 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_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
更新 ActiveInspector.CurrentItem
上的类别会生成保存提示。
选择:
olItem.Save
或 mailItem.Save
在您方便的时候。