Discussion :

[LANGAZOU]

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.

[SfJ5Rpw8]

Bonjour,




commence par mettre en oeuvre cela par exemple :

• Comment enregistrer les pièces jointe d'un mail sur une règle à la réception d'un mail ?

[Oliv-]

salut
tu peux aussi lire les post récents le même sujet vient d être abordé

[LANGAZOU]

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 .

[Oliv-]

Bonjour,
regarde ce post par exemple
http://www.developpez.net/forums/d13...mail-dossiers/

[LANGAZOU]

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.

[Oliv-]

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

[LANGAZOU]

Bonsoir Oliv-,

Je vais le tester lundi et vous tenir informé.

Merci pour votre aide precieuse.

[LANGAZOU]

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 ;-)

[Oliv-]

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

[LANGAZOU]

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.

[LANGAZOU]

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.

[Oliv-]

Ç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

[LANGAZOU]

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.

[Oliv-]

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 ?

[LANGAZOU]

Bonjour Oliv,

Les pieces jointes portent des noms differents.

[Oliv-]

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

[LANGAZOU]

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 ?

[Oliv-]

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.

[LANGAZOU]

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é !