Règles Outlook VBA

Version imprimable

Règles Outlook VBA

:salut:,

J'ai besoin de faire une macro pour créer des règles Outlook.

J'ai utilisé l'exemple du site https://msdn.microsoft.com/VBA/Outlo...method-outlook en l'adaptant à mes besoins.

Le déplacement vers un dossier et les exceptions du sujet fonctionnent, mais pas les conditions du sujet et l’ajout dans une catégorie.

Code testé :

Code:

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
 
 
Sub CreateOutlookRule()
 
    Dim colRules As Outlook.Rules:salut:
    Dim oRule As Outlook.Rule
    Dim colRuleActions As Outlook.RuleActions
 
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
    Dim oSubjectCondition As Outlook.TextRuleCondition
    Dim oExceptSubject As Outlook.TextRuleCondition
    Dim oCategory As Outlook.AssignToCategoryRuleAction
 
    Dim oInbox As Outlook.folder
    Dim oMoveTarget As Outlook.folder
 
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set oMoveTarget = oInbox.Folders("test")
    Set colRules = Application.Session.DefaultStore.GetRules()
    Set oRule = colRules.Create("TEST", olRuleReceive)
 
    'Deplacer le message vers un dossier
    Set oMoveRuleAction = oRule.Actions.MoveToFolder
    With oMoveRuleAction
        .Enabled = True
        .folder = oMoveTarget
    End With
 
    'Ajouter le message à une catégorie
    Set oCategory = oRule.Action.AssignToCategory
    With oCategory
        .Enabled = True
        .Categories = Array("test")
    End With
 
    'Mots que le sujet doit contenir
    Set oSubjectCondition = oRule.Condition.Subject
    With oSubjectCondition
        .Enabled = True
        .Text = Array("test")
    End With
 
    'Mots que le sujet ne doit pas contenir
    Set oExceptSubject = oRule.Exceptions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array("RE:", "FW:")
    End With
 
    colRules.Save
End Sub

Pourriez-vous me donner un coup de main svp ?

Merci pour votre aide.

Bonjour,
As tu un message d'erreur ?

essaye comme cela

Code:

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
 
 
Sub CreateOutlookRule()
 
    Dim colRules As Outlook.Rules:salut:
    Dim oRule As Outlook.Rule
    Dim colRuleActions As Outlook.RuleActions
 
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
    Dim oSubjectCondition As Outlook.TextRuleCondition
    Dim oExceptSubject As Outlook.TextRuleCondition
    Dim oCategory As Outlook.AssignToCategoryRuleAction
 
    Dim oInbox As Outlook.folder
    Dim oMoveTarget As Outlook.folder
 
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set oMoveTarget = oInbox.Folders("test")
    Set colRules = Application.Session.DefaultStore.GetRules()
    Set oRule = colRules.Create("TEST", olRuleReceive)
 
    'Deplacer le message vers un dossier
    Set oMoveRuleAction = oRule.Actions.MoveToFolder
    With oMoveRuleAction
        .Enabled = True
        .folder = oMoveTarget
    End With
 
    'Ajouter le message à une catégorie
    Set oCategory = oRule.Actions.AssignToCategory
    With oCategory
        .Enabled = True
        .Categories = Array("test")
    End With
 
    'Mots que le sujet doit contenir
    Set oSubjectCondition = oRule.Conditions.Subject
    With oSubjectCondition
        .Enabled = True
        .Text = Array("test")
    End With
 
    'Mots que le sujet ne doit pas contenir
    Set oExceptSubject = oRule.Exceptions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array("RE:", "FW:")
    End With
 
    colRules.Save
End Sub

07/07/2017, 10h45
Fulv95

Effectivement ça fonctionne.

:merci: pour ton aide.
07/07/2017, 15h00
Fulv95

1 pièce(s) jointe(s)

J'ai mis ma macro dans un fichier Excel et lorsque je l'exécute j'ai l'erreur "Run-time error '438' : Object doesn't support property or method" sur la ligne Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox).
07/07/2017, 17h01
Oliv-
parce que excel n'est pas outlook !
il faut ajouter une référence à "Microsoft Outlook xx.x Object Library" dans outils /références de VBE
Code:

1 2 3 4 5 6 7 Dim OL As Outlook.Application If UCase(Application) = "OUTLOOK" Then Set OL = Application Else Set OL = CreateObject("outlook.application") End If
et tu remplaces "Application." par "OL." (dans le précédent code uniquement)

Pour ajouter la référence automatiquement depuis vba j'ai essayé le code du site https://www.developpez.net/forums/d2...n-d-reference/ en l'adaptant.

Code:

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
 
Sub add1()
    Dim NomComplet As String
    NomComplet = "C:\Program Files(x86)\Microsoft Office\Root\Office16\MSOU"
    ThisWorkbook.VBProject.References.AddFromFile NomComplet
End Sub
 
Sub add2()
    If Not ReferenceActive("Microsoft Outlook 16.0 Object Library") Then
        ActiverReference "C:\Program Files(x86)\Microsoft Office\Root\Office16\MSOU"
    End If
End Sub
 
Function ReferenceActive(Nom As String) As Boolean
    Dim i As Integer
    Dim NbreRef As Integer
 
    NbreRef = ThisWorkbook.VBProject.References.Count
 
    For i = 1 To NbreRef
        If ThisWorkbook.VBProject.References(i).Name = Nom Then
            ReferenceActive = True
            Exit Function
        End If
    Next i
End Function

Avec la méthode add1() j'obtiens l'erreur : "Sub or Fonction not define"

Avec la méthode add2() : "Method VBproject' of object' _Workbook' failed"

10/07/2017, 12h30
Oliv-

Bonjour,
Pourquoi veux tu ajouter la référence automatiquement ? tu as plusieurs versions de Office qui vont utiliser ta macro ?
10/07/2017, 13h29
Fulv95

Bonjour,

Je veux ajouter la référence automatiquement pour eviter aux utilisateurs de le faire.

Une fois que tu as ajouté la référence elle reste dans ton fichier Excel ! Tu n'as besoin de changer cette réfécence que si les utilisateurs ont des versions différentes de OFFICE.

Sinon tu peux utiliser le LATE BINDING

Code:

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
 
 
Sub CreateOutlookRule()
Dim OL As Outlook.Application
 
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
const olFolderInbox= 6
Const olRuleReceive=0
 
    Dim colRules As Object   'Outlook.Rules
    Dim oRule As Object   'As Outlook.Rule
    Dim colRuleActions As Object   'As Outlook.RuleActions
 
    Dim oMoveRuleAction As Object   'As Outlook.MoveOrCopyRuleAction
    Dim oSubjectCondition As Object   'As Outlook.TextRuleCondition
    Dim oExceptSubject As Object   'As Outlook.TextRuleCondition
    Dim oCategory As Object   'As Outlook.AssignToCategoryRuleAction
 
    Dim oInbox As Object   'As Outlook.folder
    Dim oMoveTarget As Object   'As Outlook.folder
 
    Set oInbox = OL.Session.GetDefaultFolder(olFolderInbox)
    Set oMoveTarget = oInbox.Folders("test")
    Set colRules = OL.Session.DefaultStore.GetRules()
    Set oRule = colRules.Create("TEST", olRuleReceive)
 
    'Deplacer le message vers un dossier
    Set oMoveRuleAction = oRule.Actions.MoveToFolder
    With oMoveRuleAction
        .Enabled = True
        .folder = oMoveTarget
    End With
 
    'Ajouter le message à une catégorie
    Set oCategory = oRule.Actions.AssignToCategory
    With oCategory
        .Enabled = True
        .Categories = Array("test")
    End With
 
    'Mots que le sujet doit contenir
    Set oSubjectCondition = oRule.Conditions.Subject
    With oSubjectCondition
        .Enabled = True
        .Text = Array("test")
    End With
 
    'Mots que le sujet ne doit pas contenir
    Set oExceptSubject = oRule.Exceptions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array("RE:", "FW:")
    End With
 
    colRules.Save
End Sub

10/07/2017, 14h38
Fulv95

Ok, :merci: beaucoup pour ton aide