Bonjour,
Avec une macro, je réussi à classer des courriels et à extraire les pièces-jointes.
Mon problème, est que si je classe plus d'un courriel et que dans ces courriels il y a des pièces-jointes, celles-ci s'extrairont autant de fois que j'ai de courriel à classer.
Exemple: 3 courriels :courriel 1 = 4pièces-jointes, courriel 2 = 1 pièce-jointe et courriel 3 = 1 courriel.
Résultat: j'ai mes 3 courriels de classer et 18 pièces-jointes. Les 6 pièces-jointes se sont extraites 3 fois.
Comment faire en sorte qu'il n'y ait que 6 pièces-jointes ?
Voici mon 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 For i = 1 To SEL_ORI.Count Step 1 ' Classer plus d'un courriel. stEmailReunion = True Set EMAIL = SEL_ORI.Item(i) ' erreur 13 If stEmailReunion = True Then ' une réunion ... 'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé Dim memPath As Variant intCpt = 1 '+ Len(stFichier) memPath = stFichier 'FileName While Dir(stFichier) <> "" ' While Dir(FolderName & "\" & FileName) <> "" ' Le fichier existe déjà stFichier = Left(memPath, Len(memPath) - 4) & "_" & intCpt & ".msg" intCpt = intCpt + 1 Wend ' Si case à cocher chk p-j reçues, voir dans procédure SaveAttachment If EMAIL.SenderName <> stNom And forGCourriels.chkExtrairePJr.Value = True Then ' **** procédure ci-dessous SaveAttachment FolderName End If ' Si case à cocher chk p-j envoyées If EMAIL.SenderName = stNom And forGCourriels.chkExtrairePJe.Value = True Then ' **** procédure ci-dessous SaveAttachment FolderName End If ' ***************************************************** forGCourriels.lstCourriel.AddItem Left(EMAIL.ReceivedTime, InStr(EMAIL.ReceivedTime, " ") - 1) & " -- " & DeQui & " -- OBJET: " & EMAIL.Subject 'FileName ' *********Fin de la Nomination du fichier ******************************************** ... End If Next
Voici la procédure SaveAttachment :
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 Sub SaveAttachment(STFolderName As String) ' Extraire la pièce-jointe ' MAJ 2017-04-18 LP Dim myItems, myItem, myAttachments, myAttachment As Object Dim stChemin As String Dim myOlApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim stCourriels As Outlook.Selection Dim intCourriel, intCpt As Integer Dim memPath, memPath1 As Variant Dim boTypeATT As Boolean intCpt = 1 intCourriel = 0 stChemin = STFolderName & "\" On Error Resume Next 'Actions sur les objets sélectionnés Set myOlExp = myOlApp.ActiveExplorer Set stCourriels = myOlExp.Selection 'boucle For Each myItem In stCourriels Set myAttachments = myItem.Attachments If myAttachments.Count > 0 Then 'pour toutes les pièces-jointes... For intCourriel = 1 To myAttachments.Count ' vérifie si c'est une PJ ou image dans le courriel MAJ 2018-02-05 boTypeATT = PJ_Isembedded(myAttachments(intCourriel)) ' voir fonction ci-dessous. If boTypeATT = False Then intCpt = 1 ' ***************************************************** memPath = stChemin & myAttachments(intCourriel).FileName memPath1 = stChemin & myAttachments(intCourriel).FileName Do While Dir(memPath1) <> "" ' Le fichier existe déjà memPath1 = Left(memPath, Len(memPath) - 4) & "_" & intCpt & "." & Right(memPath, 3) intCpt = intCpt + 1 If intCpt > 5000 Then Exit Do End If Loop ' ***************************************************** 'save them to destination myAttachments(intCourriel).SaveAsFile memPath1 'stChemin & _ 'myAttachments(intCourriel).FileName End If Next intCourriel myItem.Save End If Next Set myItems = Nothing Set myItem = Nothing Set myAttachments = Nothing Set myAttachment = Nothing Set myOlApp = Nothing Set myOlExp = Nothing Set stCourriels = Nothing End Sub
Partager