Enregistrer des pièces jointes automatiquement

**r.sandrine** · 19/01/2018, 10h34

Bonjour

Je reçois un grand nombre d’emails par jour avec des pièces jointes qui doivent être archivées sur l’ordinateur.
Je souhaiterais enregistrer automatiquement ces pièces jointes.

J'ai pu trouver le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\pj"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

Je souhaiterais que dans le dossier "c:\temp\pj", les emails soient classés
- dans un dossier par expéditeur de l'email (le nom, pas l'adresse par exemple Jean DUPONT)
- dans un sous dossier avec l'objet de l'email + date et heure
Le système devra donc les créer automatiquement

Comment modifier ce code ?

Merci beaucoup

**Oliv-** · 20/01/2018, 18h24

A peu prêt comme cela (j'ai pas vérifié!)

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
 
Sub test_saveAttachtoDisk()
saveAttachtoDisk ActiveInspector.CurrentItem
End Sub
 
 
 
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\pj"
 
saveFolder = saveFolder & "\" & itm.SenderName & "\" & itm.Subject & "[" & Format(itm.ReceivedTime, "yyyymmdd-hhnnss") & "]"
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
 
Private 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é
'----------------------------------------------------------------------
    On Error Resume Next
    Dim fso As Object, i As Integer, retour As Boolean
    Dim rp As String, r
    Dim rep, REP_TOP
 
    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

Par contre tu dois tenir compte des caractères interdits dans le chemin d'un fichier, des doublons dans les pièces jointes, etc

tu peux consulter cela
https://www.developpez.net/forums/bl...yperlien-mail/

**r.sandrine** · 22/01/2018, 14h36

Merci beaucoup, je vais essayer ça

Qu'est ce que je peux rajouter au code pour que seules les pièces jointes soient enregistrées et pas les images contenues dans le corps du message ?

Merci

**Oliv-** · 22/01/2018, 14h40

Tout est dans le lien précédent

**r.sandrine** · 22/01/2018, 15h00

Je travaille sur le code que tu m'as donné dans ton message, j'ai une erreur ici

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Sub saveAttachtoDiskTest(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\pj"
 
saveFolder = saveFolder & "\" & itm.SenderName & "\" & itm.Subject & "[" & Format(itm.ReceivedTime, "yyyymmdd-hhnnss") & "]"
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

Nom : erreur.png
Affichages : 1488
Taille : 10,4 Ko

Le dossier avec l'expéditeur est bien créé mais pas le sous-dossier et le message n'est pas enregistré.

Merci

**r.sandrine** · 22/01/2018, 15h41

J'ai ajouté la fonction pour les caractères interdits, néanmoins le dossier de l'expéditeur se créée sans erreur mais rien n'est enregistré (ni le sous dossier de l'objet ni les pièces jointes)

Ca me donne ça comme 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
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
 
 
Sub test_saveAttachtoDisk()
saveAttachtoDisk ActiveInspector.CurrentItem
End Sub
 
 
Public Sub saveAttachtoDiskTest(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\pj\"
 
saveFolder = saveFolder & "\" & itm.SenderName & "\" & itm.Subject & "[" & Format(itm.ReceivedTime, "yyyymmdd-hhnnss") & "]"
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
objAtt.SaveAsFile remplaceCaracteresInterdit(saveFolder & "\" & objAtt.DisplayName)
Set objAtt = Nothing
Next
End Sub
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
    Dim objCurrentMessage As Outlook.MailItem
 
    Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
        CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = CheminStr
    'MsgBox CheminStr
 
End Function
 
Private 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é
'----------------------------------------------------------------------
    On Error Resume Next
    Dim fso As Object, i As Integer, retour As Boolean
    Dim rp As String, r
    Dim rep, REP_TOP
 
    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

Merci

**Oliv-** · 22/01/2018, 15h52

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
 
saveFolder=remplaceCaracteresInterdit(saveFolder)
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & remplaceCaracteresInterdit(objAtt.DisplayName)
Set objAtt = Nothing
Next
End Sub

**r.sandrine** · 22/01/2018, 16h32

J'y suis finalement arrivée avec le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
 
Public Sub saveAttachtoDiskTest(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\pj\"
saveFolder = saveFolder & "\" & remplaceCaracteresInterdit(itm.SenderName) & "\" & remplaceCaracteresInterdit(itm.Subject) & "[" & Format(itm.ReceivedTime, "ddmmyy-hhnn") & "]"
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & remplaceCaracteresInterdit(objAtt.DisplayName)
Set objAtt = Nothing
Next
End Sub

Super. Je n'y connais pas grand chose en code, d'où vient le "-RECU" dans le nom du dossier qui correspond à l'objet de l'email ?

J'ai regardé le lien que tu m'as donné mais ne comprenant pas trop le code je ne sais pas quoi en faire

Où puis je ajouter les instructions qui correspondent pour ne pas enregistrer les images dans le corps de l'email ? (dans ma société les signatures sont au format jpg ...)

Merci beaucoup

**Oliv-** · 22/01/2018, 21h33

La fonction a utiliser pour savoit si c'est une pj ou une image incorporée dans le corps du mail
c'est cette partir là du lien

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
  'vérification si c'est une  PJ  Embedded
            TypeAtt = PJ_Isembedded(pj)
 If TypeAtt = False then 
'on enregsitre la pj
else
'rien
end if

**r.sandrine** · 23/01/2018, 12h11

Merci j'ai enregistré la fonction, mais comment je l'intègre dans le code ?

merci beaucoup.

**Oliv-** · 23/01/2018, 12h39

Il faut récupérer la fonction PJ_Isembedded sur le lien https://www.developpez.net/forums/bl...yperlien-mail/

Ensuite dans ton code tu dois appliquer l'exemple cité précédemment :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
For Each objAtt In itm.Attachments

'ICI  TU TESTES LA PJ AVEC PJ_Isembedded 

IF.......

objAtt.SaveAsFile saveFolder & "\" & remplaceCaracteresInterdit(objAtt.DisplayName)

END IF...

Set objAtt = Nothing
Next

Tu dois essayer de comprendre les codes en exemple et les modifier pour atteindre ton objectif. Je pourrais le faire pour toi mais ce n'est pas constructif.

**r.sandrine** · 23/01/2018, 14h09

Avec le code ci-dessous, j'ai une erreur "objet requis " sur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TypeAtt = PJ_Isembedded(pj)

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
 
Sub test_saveAttachtoDisk()
saveAttachtoDisk ActiveInspector.CurrentItem
End Sub
 
Public Sub saveAttachtoDiskTest(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim pj, TypeAtt
 
saveFolder = "C:\temp\pj"
saveFolder = saveFolder & "\" & remplaceCaracteresInterdit(itm.SenderName) & "\" & remplaceCaracteresInterdit(itm.Subject) & "[" & Format(itm.ReceivedTime, "ddmmyy-hhnn") & "]"
 
Call waaps_creedir(saveFolder)
 
For Each objAtt In itm.Attachments
 
TypeAtt = PJ_Isembedded(pj)
 
If TypeAtt = False Then
objAtt.SaveAsFile saveFolder & "\" & remplaceCaracteresInterdit(objAtt.DisplayName)
End If
 
Set objAtt = Nothing
 
Next
End Sub
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
    Dim objCurrentMessage As Outlook.MailItem
 
    Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
        CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = CheminStr
    'MsgBox CheminStr
 
End Function
 
Private 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é
'----------------------------------------------------------------------
    On Error Resume Next
    Dim fso As Object, i As Integer, retour As Boolean
    Dim rp As String, r
    Dim rep, REP_TOP
 
    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
 
Function PJ_Isembedded(ByVal pj As Attachment) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : PJ_Isembedded pour OL2010
' Author    : OLIV-
' Date      : 05/06/2015
' Version   : 2
' Purpose   : Indique VRAI si une PIECE JOINTE est INCORPOREE dans le Corps du Mail
'---------------------------------------------------------------------------------------
'
    Dim oPA As Outlook.PropertyAccessor
 
    Dim ATTACH_MIME_TAG
    Dim ATTACH_CONTENT_ID
    Dim ATTACHMENT_HIDDEN
    Dim ATTACH_FLAGS
    Dim ATTACH_CONTENT_LOCATION
    Dim ATTACH_METHOD
 
 
    Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
    Const PR_ATTACH_CONTENT_LOCATION = "http://schemas.microsoft.com/mapi/proptag/0x3713001E"
    Const PR_ATTACH_METHOD = "http://schemas.microsoft.com/mapi/proptag/0x37050003"
 
    Set oPA = pj.PropertyAccessor
 
    On Error Resume Next
    ATTACH_MIME_TAG = oPA.GetProperty(PR_ATTACH_MIME_TAG)
    ATTACHMENT_HIDDEN = oPA.GetProperty(PR_ATTACHMENT_HIDDEN)
    ATTACH_CONTENT_ID = oPA.GetProperty(PR_ATTACH_CONTENT_ID)
    ATTACH_FLAGS = oPA.GetProperty(PR_ATTACH_FLAGS)
    ATTACH_CONTENT_LOCATION = oPA.GetProperty(PR_ATTACH_CONTENT_LOCATION)
    ATTACH_METHOD = oPA.GetProperty(PR_ATTACH_METHOD)
 
    'MsgBox pj & vbCr & "PR_ATTACH_MIME_TAG=" & ATTACH_MIME_TAG _
         & vbCr & "PR_ATTACHMENT_HIDDEN=" & ATTACHMENT_HIDDEN _
         & vbCr _
         & vbCr & "PR_ ATTACH_CONTENT_ID=" & ATTACH_CONTENT_ID _
         & vbCr & "PR_ATTACH_FLAGS=" & ATTACH_FLAGS _
         & vbCr & "PR_ATTACH_CONTENT_LOCATION=" & ATTACH_CONTENT_LOCATION _
         & vbCr & "PR_ATTACH_METHOD=" & ATTACH_METHOD
 
    If (ATTACH_CONTENT_ID <> "" And ATTACH_FLAGS = 4) Or ATTACH_METHOD = 6 Then
        PJ_Isembedded = True
    Else
        PJ_Isembedded = False
    End If
 
End Function

Merci

**Oliv-** · 23/01/2018, 14h20

oui parce que l'objet pj n'existe pas

en fait tu dois remplacer pj par objAtt qui est l'objet qui désigne la pièce jointe que tu es en train de traiter

**r.sandrine** · 23/01/2018, 14h29

C'est bon, plus d'erreur.
Par contre si je reçois un email avec une image incorporée mais pas de pièce jointe j'ai un dossier qui se créé, peut-on éviter ça ?

Merci beaucoup

**Oliv-** · 23/01/2018, 14h40

Oui, tu dois déplacer ton traitement (création de dossier) dans ta condition réalisée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
For Each objAtt In itm.Attachments
 
TypeAtt = PJ_Isembedded(pj)
 
If TypeAtt = False Then
Call waaps_creedir(saveFolder)
objAtt.SaveAsFile saveFolder & "\" & remplaceCaracteresInterdit(objAtt.DisplayName)
End If

en principe il faudrait créer une variable pour dire que "pour cet Email j'ai créé le dossier d'export" après le premier IF pour éviter le traitement waaps_creedir, mais tu peux faire sans.

**r.sandrine** · 23/01/2018, 14h50

Super, merci beaucoup, ça marche

et merci encore pour la patience ...

**r.sandrine** · 29/01/2018, 08h35

Bonjour

Après quelques jours d’utilisation j’ai parfois une erreur « dossier inexistant » sur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
objAtt.SaveAsFile saveFolder & "\" & "\" & "[" & Format(itm.ReceivedTime, "ddmmyy-hhnn") & "]" & "_ " & remplaceCaracteresInterdit(objAtt.DisplayName)

Pourtant sur la plupart des messages la macro créé bien le dossier de l’expéditeur et ensuite de l’objet de l’email, puis enregistre dedans les pièces jointes.
Mais sur les messages où il y a ces erreurs seul le dossier de l’expéditeur est créé.

Voici le code complet :

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
Public Sub saveAttachtoDisk_exp_objet(itm As Outlook.MailItem)
'Cette macro créé un dossier par expéditeur et enregistre les pièces jointes
 
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim TypeAtt
 
saveFolder = "C:\temp\pj"
saveFolder = saveFolder & "\" & remplaceCaracteresInterdit(itm.SenderName) & "\" & "[" & Format(itm.ReceivedTime, "ddmmyy-hhnn") & "]" & remplaceCaracteresInterdit(itm.Subject)
 
For Each objAtt In itm.Attachments
 
TypeAtt = PJ_Isembedded(objAtt)
 
If TypeAtt = False Then
Call waaps_creedir(saveFolder)
objAtt.SaveAsFile saveFolder & "\" & "\" & "[" & Format(itm.ReceivedTime, "ddmmyy-hhnn") & "]" & "_ " & remplaceCaracteresInterdit(objAtt.DisplayName)
 
End If
 
Set objAtt = Nothing
 
Next
End Sub

D'où ça peut venir ?

Merci
Sandrine

**Oliv-** · 29/01/2018, 09h48

Bonjour,

pourquoi cela ? le \ est un caractère réservé en principe \\ t'envoi vers un lecteur réseau

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 & "\" & "\" &

il faut en supprimer 1

**r.sandrine** · 29/01/2018, 09h54

Merci, je vais essayer d'en enlever 1 et voir comment se comportent les prochains emails.

**r.sandrine** · 29/01/2018, 10h04

Ca n'a pas été long, l'erreur subsiste, sur un email en particulier
Dossier d'expéditeur créé, mais pas le sous dossier de l'objet ni les pièce jointes

Rien de spécial dans l'objet de l'email si ce n'est RE: mais ça ne devrait pas poser de problème avec le remplaceCaracteresInterdit
Par contre je remarque des # dans les noms des pièces jointes, j'ai modifié le remplaceCaracteresInterdit en rajoutant le # mais cet email entraine toujours une erreur.

Nom : capture.png
Affichages : 1453
Taille : 16,8 Ko

Nom : capture.png
Affichages : 1453
Taille : 16,8 Ko

Enregistrer des pièces jointes automatiquement

Outlook

Discussions similaires

Partager

Partager