1. #1
    Membre régulier
    Profil pro
    Inscrit en
    août 2010
    Messages
    170
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : août 2010
    Messages : 170
    Points : 91
    Points
    91

    Par défaut 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 : 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

  2. #2
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 326
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 326
    Points : 5 793
    Points
    5 793
    Billets dans le blog
    16

    Par défaut

    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
    et dans la première partie tu fais

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    SaveAttachment Email, FolderName

  3. #3
    Membre régulier
    Profil pro
    Inscrit en
    août 2010
    Messages
    170
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : août 2010
    Messages : 170
    Points : 91
    Points
    91

    Par défaut

    En effet, je voyais que j'avais une boucle de trop, mais je ne voyais pas où. J'étais trop dans le code.

    Merci.

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Extraire Pièces jointe (*.xls et *.zip uniquement) d'outlook
    Par roidurif dans le forum Macros et VBA Excel
    Réponses: 7
    Dernier message: 23/12/2009, 10h14
  2. Réponses: 3
    Dernier message: 26/11/2008, 18h00
  3. Réponses: 1
    Dernier message: 10/03/2008, 21h36
  4. Réponses: 6
    Dernier message: 14/11/2006, 10h35

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo