Créer une règle pour déplacer un e-mail par domaine d'expéditeur

Question

Actuellement, je peux utiliser la macro ci-dessous pour créer une règle qui enverra tous les e-mails avec l'adresse de l'expéditeur sélectionné dans un dossier désigné.

Cela fonctionne très bien. Cependant je veux créer la règle pour envoyer tous les email de ce domaine (indépendamment de l'expéditeur) au dossier.

Voici le code que j'utilise actuellement.

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

Ok, donc après beaucoup plus de diggings/essais et erreurs. J'ai trouvé une solution. La principale chose à voir est que le type est "AddressRuleCondition" et la propriété que vous voulez modifier n'est pas "Text", mais est "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