Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

VBA Outlook Discussion :

Extraire des pièces jointes et les sauvegarder


Sujet :

VBA Outlook

  1. #1
    Membre du Club
    Extraire des pièces jointes et les sauvegarder
    Bonjour,

    J'ai un dossier sous "OUTLOOK" qui contient des mails avec pièces jointes. je voulais extraire ces pièces jointes et les enregistrer dans un dossier sous bureau avec création des sous dossiers selon la date de la réception du mail (exple: création d'un sous dossier "2015" si l'année de réception de la pièce jointe est en 2015 et sous ce dossier "2015" il y'aura création d'un autre sous dossier "Janvier 2015" si la pièce jointe a été reçue en janvier 2015 et l'enregistrer par la suite).

    Merci pour votre aide.

  2. #2

  3. #3

  4. #4
    Membre du Club
    Bonjour Oliv-,

    Merci pour votre réponse.
    en se référent au lien envoyé par Mr bbil, j'ai pas su qu'est ce que je devrais modifier pour l'adapter à mon cas. ci-dessous le code standard:

    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
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
     
    ' ***olivier CATTEAU***
     
    ' 23 avril 2007
     
        Dim olNS As Outlook.namespace
        Dim MyMail As Outlook.MailItem
     
        Dim expediteur
        Set olNS = Application.GetNamespace("MAPI")
        Set MyMail = olNS.GetItemFromID(strID.EntryID)
     
        'MsgBox "nouveau message"
     
        If MyMail.Attachments.Count > 0 Then
     
            expediteur = MyMail.SenderEmailAddress
     
            'on crée le répertoire où mettre les fichiers joints ##########################################################
     
            'c:\temp\pj\ doit déjà exister !!!
     
            Repertoire = "c:\temp\pj\" & expediteur & "\"
     
            If Repertoire <> "" Then
     
                If "" = Dir(Repertoire, vbDirectory) Then
     
                    MkDir Repertoire
     
                End If
     
            End If
     
            'on traite les pj
     
            Dim PJ, typeatt
     
            For Each PJ In MyMail.Attachments
                'vérification si c'est une PJ Embedded
     
                typeatt = Isembedded(strID, PJ.Index)
     
                If typeatt = "" Then
     
                    If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
     
                        MsgBox Repertoire & PJ.FileName & " existe !!"
     
                        'si existe copie vers le répertoire old
     
                        If "" = Dir(Repertoire & "old", vbDirectory) Then
     
                            MkDir Repertoire & "old"
     
                        End If
     
                        FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
     
                    End If
     
                    PJ.SaveAsFile Repertoire & PJ.FileName
     
                End If
     
            Next PJ
     
            'drapeau vert
     
            MyMail.FlagIcon = olGreenFlagIcon
     
            'Marque lu
     
            MyMail.UnRead = False
     
            MyMail.Save
     
            'on déplace le mail vers un sous dossier outlook
     
            Dim myDestFolder As Outlook.MAPIFolder
     
            Set myDestFolder = MyMail.Parent.Folders("test")
            MyMail.Move myDestFolder
     
        End If
     
        Set MyMail = Nothing
        Set olNS = Nothing
     
    Fin:
     
    End Sub
     
     
     
    ' Function: Fields_Selector
     
    ' Purpose: View type of attachment
     
    ' olivier catteau fevrier 2006
     
    Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant
     
        Dim oSession As MAPI.Session
        ' CDO objects
     
        Dim oMsg As MAPI.Message
        Dim oAttachs As MAPI.Attachments
     
        Dim oAttach As MAPI.Attachment
     
        ' initialize CDO session
     
        On Error Resume Next
     
        Set oSession = CreateObject("MAPI.Session")
        oSession.Logon "", "", False, False
     
        ' get the message created earlier
     
        Set oMsg = oSession.GetMessage(strEntryID)
        ' set properties of the attached graphic that make
     
        ' it embedded and give it an ID for use in an image tag
     
        Set oAttachs = oMsg.Attachments
        Set oAttach = oAttachs.Item(attindex)
        Dim strCID As String
     
        strCID = oAttach.Fields(&H3712001E)
     
        Isembedded = strCID
     
        Set oMsg = Nothing
     
        oSession.Logoff
     
        Set oSession = Nothing
     
    End Function


    Merci pour votre aide habituelle .

  5. #5

  6. #6
    Membre du Club
    Bonjour Oliv-,

    Je suis débutant en VBA OUTLOOK , j'ai fouillé le code de "jibi23" mais j'ai pas su comment le modifier et integrer le repertoire source qui contient les pieces jointes. s'il y'a quelques modifications à faire merci de m'aider SVP.

    Merci.

  7. ###raw>post.musername###
    Expert éminent
    Bonjour,
    Pourtant il n'y avait qu'une ligne à modifier !

    Il faut lancer Extrait_Pieces_Jointes et se laisser guider.

    Il y a des limitations à ce code notamment :

    une pj ayant le même nom qu'une existante écrasera la première.
    Les images dans le corps du Mail sont également exportées.

    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
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    'http://www.developpez.net/forums/d1377463/logiciels/microsoft-office/outlook/vba-outlook/macro-vba-sauvegarde-pieces-jointes-p-objets-corps-mail-dossiers/
    '-- Variable globale contenant le répertoire de référence de sauvegarde
    Dim REP_TOP As String
    
    Sub Extrait_Pieces_Jointes()
    '----------------------------------------------------------------------
    ' Routine :    Extrait_Pieces_Jointes
    '----------------------------------------------------------------------
    ' Paramètres : aucun ...
    '----------------------------------------------------------------------
    '   retour :    Boite de dialogue "Terminé"
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    
        Dim myNameSpace As NameSpace, fld As MAPIFolder, pfld As MAPIFolder, sfld As MAPIFolder
        Dim myItem As MailItem, Piece As Attachment
        Dim doc As String, rep As String
    Dim test
        '-- Choix et contrôle du disque de destination
        rep = InputBox("Sur quel disque ?", "Question", "C:")
        On Error Resume Next
        ChDrive rep
        test = Err
        On Error GoTo 0
    
        If test Then
            MsgBox "Disque " & rep & " inaccessible"
            Exit Sub
        End If
    
        REP_TOP = rep & "\"
    
        '-- Choix et contrôle / création du répertoire de base
        rep = InputBox("Dans quel répertoire ?", "Question", "\temp\test\")
    
        test = waaps_creedir(rep)
    
        If Not test Then
            MsgBox "Répertoire " & rep & " inaccessible"
            Exit Sub
        End If
    
        '-- Initialisation de la variable globale du répertoire de référence
        REP_TOP = REP_TOP & "\" & rep
        REP_TOP = Replace(REP_TOP, "/", "\")
        REP_TOP = Replace(REP_TOP, "\\", "\")
    
        '-- Récupération de l'espace nommé MAPI
        Set myNameSpace = CreateObject("Outlook.Application").GetNamespace("MAPI")
    
        '-- Choix du dossier à traiter ... c'est un MAPIFolder
        Set pfld = myNameSpace.PickFolder
    
        '-- Si l'utilisateur renonce on s'en va
        If pfld Is Nothing Then Exit Sub
    
        '-- appel de la routine sauvefolder ...
        sauvefolder pfld, ""
    
        MsgBox "terminé"
    
    End Sub
    
    
    Sub sauvefolder(fld As MAPIFolder, ByVal suf As String)
    '----------------------------------------------------------------------
    ' Routine :    sauvefolder (routine récursive...)
    '----------------------------------------------------------------------
    ' Paramètres :
    '    fld : Le MAPIFolder à traiter
    '    suf : localisation /nomdedossier/nomdedossier2/
    '----------------------------------------------------------------------
    '   retour :    Aucun
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    
    '-- on entretient la localisation sur la base du nom de dossier courant
        suf = suf & fld.Name & "\"
    
        '-- On envoie une info dans la fenêtre debug pour ceux qui aiment voir ce qui se passe
        Debug.Print suf & fld.items.Count
    
        '-- On tourne sur tous les éléments du dossier courant
        For i = 1 To fld.items.Count
            '-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
            If fld.items(i).Class = olMail Then sauvefichier fld.items(i), suf
            '-- Pour voir ce qui se passe sans tout faire ... enlever le commentaire ci-dessous
            'If i = 2 Then Exit For
        Next
    
        '-- On tourne sur tous les sous-dossiers du dossier courant
        For i = 1 To fld.folders.Count
            '-- appel récursif de la fonction sauvefolder
            sauvefolder fld.folders(i), suf
        Next
    
    End Sub
    
    Sub sauvefichier(myItem As MailItem, ByVal suf As String)
    '----------------------------------------------------------------------
    ' Routine :    sauvefichier (routine récursive...)
    '----------------------------------------------------------------------
    ' Paramètres :
    '    myItem : l'item Mail à traiter
    '    suf : localisation /nomdedossier/nomdedossier2/
    '----------------------------------------------------------------------
    '   retour :    Aucun
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    
        Dim Piece As Attachment
    
        '-- on s'assure de la création / existence du répertoire de stockage
        'AJOUT OLIV- pour classement selon l'année et le mois de réception
        suf = Format(myItem.ReceivedTime, "YYYY") & "\" & Format(myItem.ReceivedTime, "YYYY-MM (MMMM)") & "\"
        waaps_creedir (suf)
        
    
        '-- On boucle sur les pièces jointes du message (si il y en a)
        For j = 1 To myItem.Attachments.Count
            '-- Initialisation de l'objet Pièce Jointe
            Set Piece = myItem.Attachments(j)
            '-- Sauvegarde du fichier correspondant.
            Piece.SaveAsFile REP_TOP & suf & j & "_" & Piece.FileName
        Next
        Set Piece = Nothing
    End Sub
    
    Function waaps_creedir(lerep As String) As Boolean
    '----------------------------------------------------------------------
    ' FUNCTION :    waaps_creedir
    '               Création d'un répertoire (récursif)
    '----------------------------------------------------------------------
    ' Paramètres :
    '   rep :       répertoire à créer par son chemin relatif % au root
    '----------------------------------------------------------------------
    '   retour :    True si le répertoire est créé
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    ' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
    '   Utilisation commerciale interdite
    '   Utilisation personnelle / professionnelle autorisée
    '   Le message courant doit être préservé
    '----------------------------------------------------------------------
        Dim fso As FileSystemObject, i As Integer, retour As Boolean
        Dim rp As String, r
    
        Set fso = CreateObject("Scripting.filesystemobject")
    
        rp = Replace(lerep, "\", "/")
        rp = Replace(rp, "//", "/")
        rep = Split(rp, "/")
        r = REP_TOP
        retour = True
        For i = 0 To UBound(rep)
            If (rep(i) <> "") Then
                r = r & rep(i) & "\"
                If (Not fso.FolderExists(r)) Then
                    fso.CreateFolder (CStr(r))
                    If (Not fso.FolderExists(r)) Then retour = False
                End If
            End If
        Next
        Set fso = Nothing
        waaps_creedir = retour
    End Function
      0  0

  8. #8
    Membre du Club
    Bonsoir Oliv-,

    Je vais le tester lundi et vous tenir informé.

    Merci pour votre aide precieuse.

  9. ###raw>post.musername###
    Membre du Club
    Bonjour Oliv-,

    Merci pour ton aide ca marche nickel !

    Juste une petite question si vous me le permettez : y'a t-il un moyen que cette macro s'exécute automatiquement tous les jours ? dans ce cas je pense qu' il faut enlever les 2 userform qui s'affichent et integrer dans le code le dossier source (\\Boîte aux lettres - SEB\Boîte de réception\Facture) et l'emplacement de sauvegarde("C:\Users\SEB\Desktop\").

    Merci beaucoup Olivier ;-)
      0  0

  10. #10
    Expert éminent
    Salut
    Et comment tu épures ce dossier et/ou gères tu le fait que les pj existent déjà ? (traitement de la veille)

  11. #11
    Membre du Club
    Salut Oliv,
    Le dossier source s'alimente qutodiennement par un nouveau mail avec piece jointe(reception automatique) c'est pour cela ma macro doit se declencher chaque jour afin d'enregistrer cette nouvelle piece jointe.

  12. #12
    Membre du Club
    Citation Envoyé par LANGAZOU Voir le message
    Salut Oliv,
    Le dossier source s'alimente qutodiennement par un nouveau mail avec piece jointe(reception automatique) c'est pour cela ma macro doit se declencher chaque jour afin d'enregistrer cette nouvelle piece jointe sur PC.

  13. #13
    Expert éminent
    Ça j avais deviné mais une fois ton export tu fais quoi de ton email ? Actuellement avec cette macro il reste dans ce dossier outlook

  14. #14
    Membre du Club
    pour le moment je les garde sur Outlook mais s'il y'a la possibilité de les effacer après avoir enregistrer les pièces jointes ça sera parfait.

  15. #15
    Expert éminent
    Salut,
    Est ce que tes pJ portent bien un nom différent ? ou alors il peut y avoir des doublons avec celles déjà exportées sur ton disque ?

  16. #16
    Membre du Club
    Bonjour Oliv,

    Les pieces jointes portent des noms differents.

  17. #17
    Expert éminent
    Alors le plus simple c'est de reprendre le premier code
    en créant une REGLE à la reception d'un Email et en executant un script : celui-ci

    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
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    Sub REGLE_extrait_PJ_vers_rep(StrID As Outlook.MailItem)
    ' ***olivier CATTEAU*** script
    ' 23 avril 2007
    'modif 02 06 2015
     
        Dim olNS As Outlook.NameSpace
        Dim Mymail As Outlook.MailItem
        Dim expediteur
        If Not StrID.Class = olMail Then Exit Sub
        Set Mymail = StrID
     
        'MsgBox "nouveau message"
     
        If Mymail.Attachments.Count > 0 Then
            expediteur = Mymail.SenderEmailAddress
     
            'on crée le repertoire où mettre les fichiers joints ##########################################################
            Repertoire = "C:\Users\SEB\Desktop\"
            'Repertoire = "C:\TEMP\"
     
            '-- on s'assure de la création / existence du répertoire de stockage
            'AJOUT OLIV- pour classement selon l'année et le mois de réception
            suf = Format(Mymail.ReceivedTime, "YYYY") & "\" & Format(Mymail.ReceivedTime, "YYYY-MM (MMMM)") & "\"
     
            Repertoire = Repertoire & suf
            waaps_creedir (Repertoire)
            'on traite les pj
            Dim pj, TypeAtt
            For Each pj In Mymail.Attachments
                'vérification si c'est une  PJ  Embedded
                'TypeAtt = PJ_Isembedded(pj)
    TypeAtt =False
                If TypeAtt = False Then
                    N = 1
                    MemPath = pj.FileName
                    PathNomExport = MemPath
                    While Dir(Repertoire & PathNomExport) <> ""
                        'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
                        PathNomExport = "(" & N & ")" & MemPath
                        N = N + 1
                    Wend
                    pj.SaveAsFile Repertoire & PathNomExport
                End If
            Next pj
     
     
            'drapeau vert
            Mymail.FlagIcon = olGreenFlagIcon
            'Marque lu
            Mymail.UnRead = False
            Mymail.Save
            'on déplace le mail vers le sous dossier outlook traité
            On Error Resume Next
            Dim myDestFolder As Outlook.MAPIFolder
            Set myDestFolder = Mymail.Parent.folders("Traité")
            On Error GoTo 0
            If myDestFolder Is Nothing Then
            Set myDestFolder = Mymail.Parent.folders.add("Traité")
            End If
     
            Mymail.Move myDestFolder
     
        End If
        Set Mymail = Nothing
        Set olNS = Nothing
    fin:
    End Sub
     
    Function waaps_creedir(lerep As String) As Boolean
    '----------------------------------------------------------------------
    ' FUNCTION :    waaps_creedir
    '               Création d'un répertoire (récursif)
    '----------------------------------------------------------------------
    ' Paramètres :
    '   rep :       répertoire à créer par son chemin relatif % au root
    '----------------------------------------------------------------------
    '   retour :    True si le répertoire est créé
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    ' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
    '   Utilisation commerciale interdite
    '   Utilisation personnelle / professionnelle autorisée
    '   Le message courant doit être préservé
    '----------------------------------------------------------------------
        Dim fso As FileSystemObject, i As Integer, retour As Boolean
        Dim rp As String, r
     
        Set fso = CreateObject("Scripting.filesystemobject")
     
        rp = Replace(lerep, "\", "/")
        rp = Replace(rp, "//", "/")
        rep = Split(rp, "/")
        r = REP_TOP
        retour = True
        For i = 0 To UBound(rep)
            If (rep(i) <> "") Then
                r = r & rep(i) & "\"
                If (Not fso.FolderExists(r)) Then
                    fso.CreateFolder (CStr(r))
                    If (Not fso.FolderExists(r)) Then retour = False
                End If
            End If
        Next
        Set fso = Nothing
        waaps_creedir = retour
    End Function

  18. #18
    Membre du Club
    Merci Olivier ;-)

    Juste un petit détail. j'arrive pas à trouver le chemin du dossier source (outlook) sur ton code ! Est ce que je dois activer Microsoft scripting run time ou autres ?

  19. #19
    Expert éminent
    Forcément car la macro va se déclencher lors de l'arrivée de ton message , il faut donc que tu changes la règle que tu dois avoir actuellement et qui déplace ton mail vers ton dossier Facture, en ajoutant l'action exécuter un script.

  20. #20
    Membre du Club
    Bonjour OLIVIER,

    Le dossier source "FACTURE" ne figure pas dans ton code. En plus j'ai mis ton code dans un nouveau module mais rien ne s'est passé !

###raw>template_hook.ano_emploi###