使用 VBA 创建 Outlook 文件夹和规则时出现问题

Question

我正在尝试在 Outlook 中创建一个 VBA 宏，它将在收件箱中为所选电子邮件的每个唯一发件人创建一个新文件夹，以及一个新规则，用于将这些发件人的未来邮件移动到适当的文件夹。但是，我无法让宏正常工作。

这是我正在使用的宏代码示例：

    Sub CreateSenderFolderAndRule()
    Dim objNS As Outlook.NameSpace
    Dim objInbox As Outlook.MAPIFolder
    Dim objMail As Outlook.MailItem
    Dim objSenderFolder As Outlook.MAPIFolder
    Dim strFolderName As String
    Dim objRules As Outlook.Rules
    Dim objRule As Outlook.Rule
    Dim objCondition As Outlook.RuleCondition
    Dim objAction As Outlook.RuleAction
    Dim objRuleExec As Object
    
    ' Get reference to the inbox
    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    
    ' Check if there is a selected item
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "Please select a message to create a folder for."
        Exit Sub
    End If
    
    ' Get the selected item (should be a mail item)
    Set objMail = Application.ActiveExplorer.Selection.Item(1)
    
    ' Check if the sender of the email is already a folder
    On Error Resume Next
    Set objSenderFolder = objInbox.Folders(objMail.SenderName)
    On Error GoTo 0
    
    ' If the folder does not exist, create it
    If objSenderFolder Is Nothing Then
        ' Create a folder with the name of the sender
        strFolderName = objMail.SenderName
        Set objSenderFolder = objInbox.Folders.Add(strFolderName, olFolderInbox)
    End If
    
    ' Create a rule to move new messages from the sender to the new folder
    Set objRules = Application.Session.DefaultStore.GetRules()
    Set objRule = objRules.Create("Move messages from " & objMail.SenderName, olRuleReceive)
    Set objCondition = objRule.Conditions.SenderEmailAddress
    With objCondition
        .Enabled = True
        .Address = objMail.SenderEmailAddress
    End With
    Set objAction = objRule.Actions.MoveToFolder
    objAction.Folder = objSenderFolder
    objRule.Enabled = True
    
    ' Save the new rule
    On Error GoTo ErrorHandler
    objRules.Save
    On Error GoTo 0
    
    ' Execute the rule
    Set objRuleExec = Application.Session.DefaultStore.GetRules.ExecuteRule(objRule.Name)
    
    ' Success message
    MsgBox "Created folder: " & objSenderFolder.Name & vbCrLf & "Created rule: " & objRule.Name
Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Number & " - " & Err.Description
End Sub

当我运行宏时，为所选电子邮件的发件人创建了一个新文件夹，但没有创建新规则，我也没有收到成功消息。

我在 Windows 10 机器上使用 Outlook 365（版本 2103），我在 Outlook 中从 VBA 编辑器运行宏。

我已尝试对代码进行各种更改，包括使用不同的 RuleCondition 参数、更改 FilterType 属性以及使用不同的文件夹创建方法，但我无法使规则生效。

任何人都可以提出解决方案吗？

Answer 1

将

Rules

对象存储在专用变量中，并在完成后调用

Rules.Save

：

set objRules = Application.Session.DefaultStore.GetRules()
Set objRule = objRules.Create("Move messages from " & objMail.SenderName, olRuleReceive)
...
objRules.Save

Answer 2

启用规则后，还必须使用

Rules.Save

保存规则，这样规则及其启用状态将在当前会话之后持续存在。规则只有在成功保存后才会启用。

请注意，保存不兼容或定义不正确的操作或条件的规则将返回错误。

此外，

Rules.Save

就与 Exchange 服务器的慢速连接的性能而言可能是一项昂贵的操作。有关使用进度对话框的更多信息，请参阅在 Outlook 对象模型中管理规则。

例如，以下 VBA 宏将消息从特定发件人移动到特定文件夹，除非消息在主题中包含某些术语：

Sub CreateRule() 
    Dim colRules As Outlook.Rules 
    Dim oRule As Outlook.Rule 
    Dim colRuleActions As Outlook.RuleActions 
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction 
    Dim oFromCondition As Outlook.ToOrFromRuleCondition 
    Dim oExceptSubject As Outlook.TextRuleCondition 
    Dim oInbox As Outlook.Folder 
    Dim oMoveTarget As Outlook.Folder 
 
    'Specify target folder for rule move action 
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox) 
    'Assume that target folder already exists 
    Set oMoveTarget = oInbox.Folders("Eugene") 
     
    'Get Rules from Session.DefaultStore object 
    Set colRules = Application.Session.DefaultStore.GetRules() 
     
    'Create the rule by adding a Receive Rule to Rules collection 
    Set oRule = colRules.Create("Dan's rule", olRuleReceive) 
 
    'Specify the condition in a ToOrFromRuleCondition object 
    'Condition is if the message is from "Dan Wilson" 
    Set oFromCondition = oRule.Conditions.From 
    With oFromCondition 
        .Enabled = True 
        .Recipients.Add ("Eugene Astafiev") 
        .Recipients.ResolveAll 
    End With 
 
    'Specify the action in a MoveOrCopyRuleAction object 
    'Action is to move the message to the target folder 
    Set oMoveRuleAction = oRule.Actions.MoveToFolder 
    With oMoveRuleAction 
        .Enabled = True 
        .Folder = oMoveTarget 
    End With 
 
    'Specify the exception condition for the subject in a TextRuleCondition object 
    'Exception condition is if the subject contains "fun" or "chat" 
    Set oExceptSubject = _ 
        oRule.Exceptions.Subject 
    With oExceptSubject 
        .Enabled = True 
        .Text = Array("fun", "chat") 
    End With 
 
    'Update the server and display progress dialog 
    colRules.Save 
End Sub