Bonjour à tous,
Première fois que je poste dans la catégorie VBA de Outlook .
Grace au site,j'ai pu écrire le code suivant pour créer des règles sur base de l'expéditeur de l'email séléctionné à ranger dans un dossier que l'on sélectionne via un User form et liste déroulante.
Aucun soucis tant que je travaillais sur ma boîte perso hors le but est de l'utiliser sur une boîte partagée. Je ne parviens pas à définir le dossier cible pour le transfert.
Merci pour votre aide:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106 Public lstNum As Long Public Sub AssignFolder() 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 Dim oFoldername As String Dim email As Outlook.MailItem Dim sender As String Dim olSpace As Outlook.NameSpace Dim olApp As Object 'Require that this procedure be called only when a message is selected If Application.ActiveExplorer.Selection.Count = 0 Then MsgBox ("No email selected") Exit Sub End If 'Specify target folder for rule move action UserForm1.Show Select Case lstNum Case 0 oFoldername = "Patricia" Case 1 oFoldername = "Paul" Case 2 oFoldername = "Stephan" Case 3 oFoldername = "Sabine" Case 4 oFoldername = "Chantal" Case 5 oFoldername = "V?ronique" End Select For Each objItem In Application.ActiveExplorer.Selection ' If objFolder.DefaultItemType = olMailItem Then If objItem.Class = olMail Then sender = objItem.SenderName ' End If End If Next Set olApp = New Outlook.Application Set olSpace = olApp.GetNamespace("MAPI") Set oInbox = olSpace.Folders("Customer Support").Store.GetDefaultFolder(olFolderInbox) 'Set oInbox = olSpace.Folders("customer.support.francebenelux@clariant.com").Store.GetDefaultFolder(olFolderInbox) 'Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox) Set oMoveTarget = oInbox.Folders(oFoldername) '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(sender, 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 (sender) .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 oRule.Execute ShowProgress:=True, Folder:=Session.GetDefaultFolder(olFolderInbox), IncludeSubfolders:=False, RuleExecuteOption:=2 End Sub
Partager