使用 VBA 创建 Outlook 文件夹和规则

Question

我正在尝试在收件箱中为所选电子邮件的每个唯一发件人创建一个文件夹，并创建一个规则以将未来的邮件从这些发件人移动到适当的文件夹。

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()
    
    ' Temporarily disable all existing rules
    Dim objExistingRule As Outlook.Rule
    For Each objExistingRule In objRules
        objExistingRule.Enabled = False
    Next objExistingRule
    
    ' Create the new rule
    Set objRule = objRules.Create("Move messages from " & objMail.SenderName, olRuleReceive)
    Set objCondition = objRule.Conditions.SenderAddress
    With objCondition
        .Enabled = True
        .Address = objMail.SenderEmailAddress
    End With
    Set objAction = objRule.Actions.MoveToFolder
    With objAction
        .Enabled = True
        .ExecutionOrder = 1 ' Ensure the rule is executed before other rules
        .Folder = objSenderFolder
    End With
    objRule.Enabled = True
    
    ' Re-enable the existing rules
    For Each objExistingRule In objRules
        objExistingRule.Enabled = True
    Next objExistingRule
    
    ' Save the rules
    objRules.Save
    
    ' Debugging code to check the rules after the new one has been created
    Debug.Print "Number of rules: " & objRules.Count
    For Each objExistingRule In objRules
        Debug.Print objExistingRule.Name & " - " & objExistingRule.Enabled
    Next objExistingRule
    
    ' Execute the rule
    Set objRuleExec = Application.Session.DefaultStore.GetRules.ExecuteRule(objRule.Name)
    
    ' Success message
    MsgBox "Created folder: " & objSenderFolder.Name & vbCrLf & "Created rule: " & objRule.Name
End Sub

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

我明白了

运行时错误'438：对象不支持此属性或方法

上线了

Set objCondition = objRule.Conditions.SenderEmailAddress 

我在 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

保存规则，以便规则及其启用状态在当前会话结束后仍然保留。规则只有在成功保存后才会启用。

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

此外，就与 Exchange 服务器的慢速连接的性能而言，

Rules.Save

可能是一项昂贵的操作。有关使用进度对话框的更多信息，请参阅管理 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