Bonjour et merci d'avance de votre aide.
Je dois sauvegarder les pièces jointes sous la condition qu'elles aientt dans leur titre "Toto " puis ensuite archiver les Emails dont la pièce jointe a été sauvegardée.
Dand le code suivant, il reste toujours dans la boite réception quelques Emails.
Pourquoi?
merci d'avance.
Inspiré, en partie de programmes du forum voici le code :
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 Sub Archivage() On Error Resume Next Dim j As Integer Dim MonApply As Outlook.Application Dim EMAIL As Outlook.MailItem Dim MonNameSpace As Outlook.NameSpace Dim Dossiers As Outlook.MAPIFolder Dim PceJointe As Outlook.Attachment Set MonApply = CreateObject("Outlook.Application") Set MonNameSpace = MonApply.GetNamespace("MAPI") Set Dossiers = MonNameSpace.Folders("Dossiers personnels") Set Destination = Dossiers.Folders("Archives") Set Breception = MonNameSpace.GetDefaultFolder(olFolderInbox) i = 0 j = 0 For Each EMAIL In Breception.Items If Not EMAIL.Attachments.Count = 0 Then For i = 1 To EMAIL.Attachments.Count Set PceJointe = EMAIL.Attachments(i) j = j + 1 Nom = PceJointe.DisplayName If Nom Like "*TOTO*" Then PceJointe.SaveAsFile "C:\Resultats\" & PceJointe.DisplayName Set Destination = Dossiers.Folders("Archives") Set EMAIL = EMAIL.Move(Destination) Set PceJointe = Nothing End If Next i End If Next EMAIL Set PceJointe = Nothing i = 0 Set MonApply = Nothing Set MonNameSpace = Nothing Set Dossiers = Nothing Set EMAIL = Nothing End Sub
Partager