创建规则以按发件人域移动电子邮件

Question

我目前能够使用下面的宏来创建一个规则，它将所有带有所选发件人地址的电子邮件发送到指定的文件夹。

这很好用。但是，我想创建规则以将来自该域的所有电子邮件（无论发件人如何）发送到该文件夹​​。

这是我目前使用的代码。

 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 oRuleCondition As Outlook.AddressRuleCondition

 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 = Application.Session.Folders("myinbox").Folders("Folders").Folders("Reference").Folders("Vendor Marketing")

 'Get Rules from Session.DefaultStore object

 Set colRules = Application.Session.DefaultStore.GetRules()

 Dim sSender As String

 For Each objItem In Application.ActiveExplorer.Selection
      If objItem.Class = olMail Then
         sSender = objItem.SenderEmailAddress
      End If
 Next

 Dim domain() As String
 domain = Split(sSender, "@")

 Dim dDomain As String
 dDomain = "@" + domain(1)

 'Create the rule by adding a Receive Rule to Rules collection
 If MsgBox("Do you want to create a rule for " + sSender + "?", vbOKCancel) = vbOK Then

     Set oRule = colRules.Create(sSender, olRuleReceive)

     'Specify the condition in a ToOrFromRuleCondition object
     Set oFromCondition = oRule.Conditions.From
     With oFromCondition
         .Enabled = True
         .Recipients.Add (sSender)
         .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

     'Update the server and display progress dialog
     colRules.Save
     oRule.Execute ShowProgress:=True
End If

Answer 1

好的，经过更多的挖掘/反复试验。我找到了解决方案。 主要看的是类型是“AddressRuleCondition”，而要修改的属性不是“Text”，而是“Address”

 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 oRuleCondition As Outlook.AddressRuleCondition    <--------HERE

 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 = Application.Session.Folders("myinbox").Folders("Folders").Folders("Reference").Folders("Vendor Marketing")

 'Get Rules from Session.DefaultStore object

 Set colRules = Application.Session.DefaultStore.GetRules()

 Dim sSender As String

 For Each objItem In Application.ActiveExplorer.Selection
      If objItem.Class = olMail Then
         sSender = objItem.SenderEmailAddress
      End If
 Next

 Dim domain() As String
 domain = Split(sSender, "@")

 Dim dDomain As String
 dDomain = "@" + domain(1)

 'Create the rule by adding a Receive Rule to Rules collection
 If MsgBox("Do you want to create a rule for " + dDomain + "?", vbOKCancel) = vbOK Then

 Set oRule = colRules.Create(dDomain, olRuleReceive)

 'Specify the condition in a ToOrFromRuleCondition object
 'Set oFromCondition = oRule.Conditions.From
 'With oFromCondition
 '.Enabled = True
 '.Recipients.Add (sSender)
 '.Recipients.ResolveAll
 'End With

 Set oRuleCondition = oRule.Conditions.SenderAddress
 With oRuleCondition
     .Enabled = True
     .Address = Array(dDomain)             <--------HERE
 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

 'Update the server and display progress dialog
 colRules.Save
 oRule.Execute ShowProgress:=True
End If