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

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

好的，所以在更多 diggings/trial 和错误之后。我找到了解决办法。主要看类型是"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

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

Create Rule to Move Email By Sender Domain

outlook

vba

rules

conditional-statements