Extraire pièces-jointes de plusieurs courriels

**marycaLou** · 05/02/2018, 17h44

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

**Oliv-** · 05/02/2018, 21h23

Bonsoir, OMG qu'as tu fais de mon code ?

Forcément tu refais des boucles, une fois que tu commences à traiter un email il est inutile de repartir de ta selection

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
Sub SaveAttachment(myItem As Outlook.mailitem, STFolderName As String)
'  Extraire la pièce-jointe
' MAJ 2017-04-18 LP
 
    Dim myAttachments, myAttachment As Object
    Dim stChemin As String
 
    Dim intCourriel, intCpt As Integer
    Dim memPath, memPath1 As Variant
    Dim boTypeATT As Boolean
 
    intCpt = 1
    intCourriel = 0
    stChemin = STFolderName & "\"
    On Error Resume Next
 
    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
    End If
 
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set stCourriels = Nothing
End Sub