Question

我为不同的项目创建了文件夹（例如Proj1，Proj2，Proj3，...）。部门的一般惯例是在主题中发送有关特定项目的电子邮件（例如＆＃34; Proj1：项目已完成！＆＃34;）。

我知道我可以为每个项目创建规则，将包含其名称的邮件移动到项目文件夹中。但是，我需要创建与我拥有的文件夹数量一样多的规则 - 因此它不是非常方便和最佳。

有没有办法创建一个规则（单个规则）（可能，使用VBA代码），其中包含所有文件夹名称的列表，从列表中搜索邮件中的任何名称＆＃39; subjucts并自动将邮件移动到相应的文件夹？

Answer 1

为了达到您想要的效果，您可以使用此宏：

Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
    If m.Subject Like "*" & fldr.Name & "*" Then m.Move fldr
Next
Set fldr = Nothing
End Sub

如果您向ThisOutlookSession模块添加以下行，则可以通过新电子邮件的到达来触发此宏：

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim o As Object
Set o = Application.Session.GetItemFromID(EntryIDCollection)
If TypeName(o) = "MailItem" Then RulesForFolders o
Set o = Nothing
End Sub

虽然，我建议您删除将邮件移动到的文件夹。相反，您可以使用保留收件箱中的所有邮件，并使用搜索文件夹按您想要的顺序对它们进行分组。这样，您可以快速搜索所有收件箱并对其进行排序以及单独的搜索文件夹。您也可以在不同的文件夹中使用相同的邮件，而不是复制它。如果您决定这样做，您的宏将需要分配类别而不是移动消息：

Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder, str As Outlook.Store
For Each str In Application.Session.Stores
    For Each fldr In str.GetSearchFolders
        If m.Subject Like "*" & fldr.Name & "*" Then
            m.Categories = m.Categories & "," & fldr.Name
            m.Save
        End If
    Next
Next
Set fldr = Nothing
Set str = Nothing
End Sub

Answer 2

我需要规则来处理子文件夹，所以我稍微修改了以前@Vladislav Andreev的答案：

Sub RulesForFolders(m As MailItem)
    Dim fldr As Outlook.Folder
    For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
        If LCase(m.Subject) Like "*" & LCase(fldr.Name) & "*" Then
            m.Move fldr
            Exit For
        End If
        For Each subFldr In fldr.Folders
            If LCase(m.Subject) Like "*" & LCase(subFldr.Name) & "*" Then
                m.Move subFldr
                Exit For
            End If
        Next
    Next
    Set fldr = Nothing
    Set subFldr = Nothing
End Sub

Outlook模板规则用于在目录之间对邮件进行排序

2 个答案: