創建規則以按發件人域名移動電子郵件

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 /試驗和錯誤。我找到了解決方案。 主要看到的是類型是「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