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 228
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 46
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 228
    Points : 5 608
    Points
    5 608
    Billets dans le blog
    15

    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.

  4. #4
    Nouveau Candidat au Club
    Homme Profil pro
    Ingénieur qualité méthodes
    Inscrit en
    février 2018
    Messages
    1
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Haute Garonne (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur qualité méthodes
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : février 2018
    Messages : 1
    Points : 1
    Points
    1

    Par défaut Sauvegarder pièce jointe dans dossier spécifique en executant script

    Bonjour,

    Je me permet de vous écrire, étant débutant en VBA, j'ai repris cette macro pour sauvegarder une pièce jointe d'un mail dans un dossier avec une règle en executant le script suivant :

    Sub SaveAttachement(Item As Outlook.MailItem)

    Set attachs = Item.Attachments
    For Each attach In attachs
    file = attach.FileName
    attach.SaveAsFile "C:\Users\Maxime.LEJEUNE\Desktop\Mail Kizeo\" & file
    Next

    End Sub

    Cependant, mes pointes jointes portent des noms différentes, et j'aimerai que cette macro puisse classer ces pièces jointes dans le sous-dossier correspondant aux premières lettres de l'intitulé de la pièce jointe.

    Exemple : pièce jointe se nommant "AAA-...." va se classer dans le dossier "AAA" etc

    Je n'arrive pas à trouver une solution avec mes recherches, si qqn pouvait m'aider !
    En vous remerciant !

    Maxime

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

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 228
    Points : 5 608
    Points
    5 608
    Billets dans le blog
    15

    Par défaut

    Bonjour,

    Ça aurait été mieux de créer un nouveau fil de discussion.

    voici un exemple basique

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    Sub SaveAttachement(Item As Outlook.MailItem)
     
    Set attachs = Item.Attachments
    For Each attach In attachs
    file = attach.FileName
    SousDossier= left(file,3)
     
    attach.SaveAsFile "C:\Users\Maxime.LEJEUNE\Desktop\Mail Kizeo\" & SousDossier &"\" & file
    Next
     
    End Sub

    (attention une pj avec le nom identique écrasera la précédente)

+ 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, 11h14
  2. Réponses: 3
    Dernier message: 26/11/2008, 19h00
  3. Réponses: 1
    Dernier message: 10/03/2008, 22h36
  4. Réponses: 6
    Dernier message: 14/11/2006, 11h35

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