Extraire pièces-jointes de plusieurs courriels
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:
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:
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 |
