Discussion :

[overcride]

Bonjour,

Je crée actuellement une macro qui déplace automatiquement mes mails lorsque je donne une catégorie.
Ex: Je met la catégorie "pub" et le message se déplace dans le dossier "pub".

La macro fonctionne presque correctement ... Lorsque mon message est déplacé, j'ai le message d'erreur suivant : "Impossible d'effectuer l'opération, l'objet ayant été supprimé".

Seriez-vous où se situe mon erreur ?

Merci d'avance

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
 
Public WithEvents AM As MailItem
 
'Lancement lors de la modification des propriétés d'un mail.
'"Name" est un string et correspond au nom de la propriété.
 
Private Sub AM_PropertyChange(ByVal Name As String)
 
    'Je définis les variables.
    Dim CategorieName As String
 
    Select Case Name
        Case "Categories" 'Si "Name" contient "Categories", je traite le mail. Sinon je laisse tomber.
            If AM.Categories <> "" Then 'Si je donne une catégorie au mail je continue le traitement.
                CategorieName = AM.Categories
                AM.Categories = CategorieName
                MoveItems (CategorieName)
            End If
    End Select
End Sub
 
'Lancement lors de la sélection d'un objet.
'"Item" est un objet et correspond au type d'objet sélectionné.
 
Private Sub Application_ItemLoad(ByVal Item As Object)
    If Item.Class = olMail Then 'Si "Item" est un mail, je récupère le mail dans la variable AM. Sinon je laisse tomber.
        Set AM = Item
    Else
        Exit Sub
    End If
End Sub
 
Private Sub MoveItems(CategorieName)
 
    'Je définis les variables.
    Dim myOlapp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myDestFolder As Outlook.Folder
 
    On Error GoTo MsgErr
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myFolder.Folders(CategorieName) 'Je définis le répertoire de destination.
    AM.Move myDestFolder 'Je déplace le mail
 
    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set myDestFolder = Nothing
 
MsgErr:
    If Err.Number = -2147221233 Then
        MsgBox "Le dossier de destination n'existe pas !", vbCritical, "Erreur !"
    Else
        MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    End If
 
    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set myDestFolder = Nothing
 
    Exit Sub
 
End Sub

[Oliv-]

Bonjour,
est ce que l'erreur se produit sur une ligne particulière ?

[overcride]

Bonjour Oliv-,

Merci de vous intéresser à mon problème.

Je ne sais pas exactement, je pense juste après la ligne 17. Tous ce passe bien car le mail se déplace correctement. Après le déplacement, j'ai le message cité plus haut avec le code erreur "0".

[Oliv-]

essaye avec après la ligne 16

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 am.save

[Oliv-]

regarde aussi ce code
https://www.developpez.net/forums/d1...e/#post8022029

parce que que si tu changes la catégorie et que tu déplaces le mail, il va se fermer.
là il y a une technique pour le réouvrir.

[overcride]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

am.save

ne change rien.
Je n'ouvre pas le mail pour donner la catégorie. Je le sélectionne dans la boite de réception, fais un clique droit et donne une catégorie. D'ailleurs je viens de remarquer que lorsque je donne une catégorie depuis un mail ouvert rien ne se passe (ce que je pense normal vu mon code).

[overcride]

J'ai réarrangé un peu mon code mais j'ai toujours mon erreur...
Par contre j'ai remarqué que mon "On Error Goto" ne me donne aucun message pour cette erreur ...

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
Public WithEvents AM As MailItem
 
Private Sub Application_ItemLoad(ByVal Item As Object)
    'Si "Item" est un mail, je récupère le mail dans la variable AM. Sinon je laisse tomber.
    If Item.Class <> olMail Then Exit Sub
    Set AM = Item
End Sub
 
'Lancement lors de la modification des propriétés d'un mail.
'"Name" est un string et correspond au nom de la propriété.
 
Private Sub AM_PropertyChange(ByVal Name As String)
 
    'Je définis les variables.
    Dim CategorieName As String
    Dim NewAM
    Dim myOlapp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myDestFolder As Outlook.Folder
 
    On Error GoTo ErrorHandler
    Select Case Name
        Case "Categories" 'Si "Name" contient "Categories", je traite le mail. Sinon je laisse tomber.
            If AM.Categories <> "" Then 'Si je donne une catégorie au mail je continue le traitement.
                CategorieName = AM.Categories 'Je récupère la catégorie donnéee.
                AM.Categories = CategorieName 'Je force l application de la catégorie sinon elle ne reste pas au déplacement.
                AM.Save
                Set myNameSpace = myOlapp.GetNamespace("MAPI")
                Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
                Set myDestFolder = myFolder.Folders(CategorieName) 'Je définis le répertoire de destination.
                If AM.Parent <> myDestFolder Then 'Si le répertoire actuel du mail et le même que celui de destination je laisse tomber.
                    If Not myDestFolder Is Nothing Then 'Si le dossier de destination n existe pas je laisse tomber. (A develloper pour demander la création dans ce cas de figure).
                        Set NewAM = AM.Move(myDestFolder) 'Je déplace le mail et le récupère dans une nouvelle variable.
                        NewAM.Save
                    End If
                End If
            End If
    End Select
 
    Exit Sub
 
ErrorHandler:
    Dim MonResultat
    MonResultat = MsgBox("Erreur n° " & Err.Number & vbCrLf & "Description : " & Err.Description, vbCritical + vbOKOnly, "Erreur d'execution")
End Sub

[Oliv-]

SAlut,
apparemment, c'est propre à l'événement AM_PropertyChange, si tu lances ta macro sur AM_OPEN par exemple cela ne le fait pas

Il faudrait que ton code mette simplement un FLAG sur le mail et qu'un autre événement fasse le déplacement

[overcride]

Salut,

Merci pour la réponse, je m'en doutais mais espérais quand même.


Du coup, j'ai pensé à m'y prendre de cette façon:

• Arrivé d'un nouveau mail;
• Boucle sur la boite de réception;
• Quand la boucle trouve un mail avec une catégorie, il le déplace.

Youpiii plus de message d'erreur, cependant j'ai plus de 8000 mails dans ma boite de réception et du coup c'est super long le traitement. Ce pourquoi j'essaie de mettre ca en place, pour facilité le tri et la recherche des nouveaux mails. (J'ai rejoins des collègues sur cette boite mail et le tri n'était pas leurs priorités apparemment ^^, et pas question que je me tape le classement des précédents messages).

Sais-tu comment je pourrai m'y prendre ?

[Oliv-]

Dès que j'ai un peu de temps je vais tester à partir de AM_PropertyChange.

Sinon pour classer tes 8000 :
1- tu deplaces tous les élément dans un dossier "non classé"
2- sinon as tu des critères pour effectuer automatiquement ce classement ?

[overcride]

Je n'avais pas pensé à les déplacer dans un dossier d'attente ... Merci . Par contre vu mes critères de classement, je ne peux presque pas classer les 8000 automatiquement.

Ma solution actuelle fonctionne bien sur mon PC mais galère un peu sur plusieurs. Quand plusieurs pc essaient de déplacer un mail au même moment, ca produit des erreurs. Du coup j'ai mis la macro automatique sur un seul pc, et sur les autres il faut cliquer dans la barre de menu pour lancer le déplacement, ce que je ne trouve pas idéal mais c'est déjà ca.

Du coup tiens moi au courant si un jour tu trouves une solution avec AM_PropertyChange stp.

[Oliv-]

Salut,

Un peu de recherche et j'ai trouvé cela
http://www.vboffice.net/en/developer...th-categories/

Je copie ici le code de Michael Bauer

Dans un MODULE

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
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, _
                                                    ByVal nIDEvent As Long, ByVal uElapse As Long, _
                                                    ByVal lpTimerFunc As Long) As Long
 
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, _
                                                     ByVal nIDEvent As Long) As Long
 
Const WM_TIMER = &H113
 
Private hEvent As Long
Private m_Callback As ThisOutlookSession
 
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
                     ByVal wParam As Long, ByVal lParam As Long _
                                         )
    If uMsg = WM_TIMER Then
        m_Callback.TimerEvent
    End If
End Sub
 
Public Function EnableTimer(ByVal Interval As Long, Callback As ThisOutlookSession) As Boolean
    If hEvent <> 0 Then
        Exit Function
    End If
    hEvent = SetTimer(0&, 0&, Interval, AddressOf TimerProc)
    Set m_Callback = Callback
    EnableTimer = CBool(hEvent)
End Function
 
Public Function DisableTimer()
    If hEvent = 0 Then
        Exit Function
    End If
    KillTimer 0&, hEvent
    hEvent = 0
End Function

Dans ThisOutlookSession :

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
Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MAPIFolder
 
Friend Sub Application_Startup()
    On Error Resume Next
    Set Explorer = Application.ActiveExplorer
End Sub
 
Private Sub Explorer_SelectionChange()
    Dim obj As Object
    Dim Sel As Outlook.Selection
 
    Set Mail = Nothing
    Set Sel = Explorer.Selection
 
    If Sel.Count > 0 Then
        Set obj = Sel(1)
        If TypeOf obj Is Outlook.MailItem Then
            Set Mail = obj
        End If
    End If
End Sub
 
Private Sub Mail_PropertyChange(ByVal Name As String)
    Dim Ns As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim Subfolder As Outlook.MAPIFolder
    Dim SubfolderName As String
 
    If Name = "Categories" Then
        Set Ns = Application.GetNamespace("MAPI")
        Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
        SubfolderName = Mail.Categories
        If Len(SubfolderName) = 0 Then Exit Sub
        Set Subfolder = Inbox.Folders(SubfolderName)
        If Subfolder.EntryID <> Mail.Parent.EntryID Then
            Set MoveToThisFolder = Subfolder
            EnableTimer 500, Me
        End If
    End If
End Sub
 
Friend Sub TimerEvent()
    DisableTimer
    If Mail Is Nothing Then Exit Sub
    If MoveToThisFolder Is Nothing Then Exit Sub
    Mail.Move MoveToThisFolder
    Set Mail = Nothing
    Set MoveToThisFolder = Nothing
End Sub

j'ai testé son code cela fonctionne bien et sans message d'erreur.

Là il utilise le fait de changer de ligne dans l'explorer, pour utiliser l'événement propertyChange
tu dois pouvoir utiliser Application_ItemLoad il faut juste changer le nom des Variables, je ne sais pas lequel est mieux je dirais Application_ItemLoad