使用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()

' 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

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

我在Windows 10机器上使用Outlook 365(版本2103)，并且我正在Outlook的VBA编辑器中运行宏。

我尝试了对代码的各种更改，包括使用不同的ruleconcondition参数，更改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