Détacher piece jointe dans dossier avec date et sujet

**tiron242** · 20/12/2018, 22h54

bonjour,
j'utilise outlook 2013
je cherche à détacher les pièces jointes des mails que je sélectionne.
le code présent dans la faq m'a déjà permis de détacher mes pj dans un fichier donné...
je souhaiterai que les pj aille dans un fichier(ça c'est ok) ou serait créé un sous-fichier par date et que devant le nom soit inscrit le sujet du mail en supprimant les caractères interdits

voici le code actuel qui fonctionne pour la 1ere partie:

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()
 
    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
 
    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "C:\temp\pj\")
 
    On Error Resume Next
 
    'Actions sur les objets sélectionnés
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
    'boucle
    For Each myItem In myOlSel
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then
            'Ajoute une remarque dans le corps du message
            myItem.Body = myItem.Body & vbCrLf & _
                "pièce jointe enlevée:" & vbCrLf
 
            'for all attachments do...
            For i = 1 To myAttachments.Count
 
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
 
            Next i
 
            'Enlève les pièces jointes du message
            While myAttachments.Count > 0
 
                myAttachments(1).Delete
 
            Wend
 
            'Sauvegarde le message sans ses pièces jointes
            myItem.Save
        End If
 
    Next
 
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub

Auriez vous une idée pour faire cela?
Merci d'avance

**Oliv-** · 21/12/2018, 20h55

BONSOIR,

ici un exemple
https://www.developpez.net/forums/bl...yperlien-mail/

**tiron242** · 21/12/2018, 22h39

bonsoir,
j 'ai bien regardé ces macro...mais étant débutant en vba, je n'arrive pas à intégrer cela pour mes besoins
la création de sous-dossier par date d'arrivée me suffirai je pense
il me restera ensuite à ne sauvegarder que les "vraies pj"...quand j'aurai réussi à résoudre mon 1er pb
je continue à chercher
merci bonne soirée

**Oliv-** · 22/12/2018, 12h32

LA macro est une fonction elle permet de classer les pj en créant un dossier /sous dossier etc, il y a plusieurs paramètres.

Si tu ne veux pas l'utiliser telle quelle tu as tous les mécanismes et fonction nécessaires pour mener à bien ton projet.

par exemple créer des dossier windows :waaps_creedir()
détecter les vrai PJ : PJ_Isembedded()
etc...

Tu devrais décomposer ton projet en étapes à réaliser ...

**tiron242** · 23/12/2018, 20h32

je continue mes essais...
y a t il moyen d'utiliser votre code https://www.developpez.net/forums/bl...hyperlien-mail sur une sélection de mails et donc pas en utilisant une règle??

**Oliv-** · 23/12/2018, 22h40

oui j'ai pas essayé mais ca doit ressembler à ç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
Sub SaveAttachmentOLIV()
 
    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
 
    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "C:\temp\pj\")
 
    On Error Resume Next
 
    'Actions sur les objets sélectionnés
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
 
Dim Mail As Outlook.MailItem
 
    'boucle
    For Each myItem In myOlSel
 
if myitem.class=olmail then
 
Set Mail= myitem
 
 
Dim  Expediteur 
Expediteur = Get_sender_SMTP(Mail)
 
Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:="c:\temp\newexportmsg", Deplace:=False, _
        DossierMove:="", BodyWrite:=True, PrefixePj:=Expediteur)
 
End if
 
 
    Next
 
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub

**tiron242** · 23/12/2018, 22h58

tout d'abord merci de prendre du temps pour essayer de me dépatouiller!
mais j'ai un soucis :
Nom : img1.jpg
Affichages : 926
Taille : 47,6 Ko

depuis le début je bute la dessus

**tiron242** · 23/12/2018, 23h35

mis à part ce soucis d' "expediteur",cela fonctionne(je n'ai pas essayé le transfert du mail dans un sous dossier d'outlook)

est il possible de ne pas catégoriser le mail(vert) mais de mettre l'indicateur drapeau seul?

Nom : img2.jpg
Affichages : 822
Taille : 9,5 Ko

Nom : img2.jpg
Affichages : 822
Taille : 9,5 Ko

**tiron242** · 26/12/2018, 13h44

bonjour,
nouveau soucis mais celui-ci plus embêtant :
j'utilise 2 boites outlook sur mon poste : la mienne et une autre partagée
la fonction détachement de la pj fonctionne bien pour les 2
sur ma boite perso le lien hypertexte apparait correctement dans le mail modifié
le problème se situe sur celle partagée où dans le mail modifié je n'ai plus le lien hypertexte en tant que tel mais uniquement du texte "brut"!!

par contre les liens hypertexte déjà existants sont conservés!!

ex:

Nom : ok.png
Affichages : 816
Taille : 2,0 Ko

Nom : ok.png
Affichages : 816
Taille : 2,0 Ko

Nom : part.png
Affichages : 816
Taille : 2,0 Ko

Avez vous une idée?

**tiron242** · 26/12/2018, 15h22

je pense en avoir trouvé la cause : cela n'a rien à voir avec la boite en elle même mais :
pour les mails html cela fonctionne bien....pour les mails texte brut par contre cela ne fonctionne pas !

il faudrait peut-être forcer un envoi en html si le mail d'origine ne l'est pas?
comment faire cela??

**Oliv-** · 28/12/2018, 18h20

Il faut copier à partir de l'article du blog les fonctions et notamment Get_sender_SMTP (code tout en bas).

Pour changer le format du mail
c'est

Code :

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

MyMail.BodyFormat = olFormatHTML

avec un MyMail.save à la fin bien sûr

pour ne pas mettre de drapeau
il faut commenter la ligne

Code :

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

MyMail.FlagIcon = olGreenFlagIcon

**tiron242** · 30/12/2018, 11h15

bonjour,
pour l'envoi en html cela fonctionne ainsi que pour le flag
par contre pour récupérer l’expéditeur cela ne fonctionne pas, et j'ai bien mis toutes les fonctions dispo en fin de code
j'essayerai en fin de semaine prochaine sur OL2013 (je suis sur OL 2007 pour mes essais...)
merci encore d'avoir pris du temps!

**tiron242** · 30/12/2018, 18h56

n'y a t il pas moyen de renommer la pj en y ajoutant le sujet du mail en + du reste?(sans les caractères interdits!) devant de préférence
ceci permettrait de faire une recherche facile dans le dossier(si jamais il venait à être déplacé du dossier d'origine...je pense à un dd externe par ex)

**Oliv-** · 30/12/2018, 22h51

Pour renommer la pj il faut utiliser le paramètre
PrefixePj

Code :

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

1
2
3
4
5
dim
prefixe=Mail.subject
 
Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:="c:\temp\newexportmsg", Deplace:=False, _
        DossierMove:="", BodyWrite:=True, PrefixePj:=prefixe)

ça c'est les fonctions,, ils doivent être dans le même module, sinon il faut enlever PRIVATE devant les procédures

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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = Oitem.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem)
 
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress
End Function
 
Function GetFromFromHeader(objMail As Outlook.MailItem) As String
'---------------------------------------------------------------------------------------
' Procedure : GetToFromHeader
' Author    : OLIV- from original code brettdj
' Date      : 04/06/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objRegex As Object
    Dim objRegM As Object
    Dim MailHeader As String
    Dim ExtractText As String
    Dim i
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
    MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
 
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .ignorecase = True
        .Pattern = "(\n)From:.*<(.+)>"
        If .test(MailHeader) Then
            Set objRegM = .Execute(MailHeader)
            For i = 0 To objRegM(0).submatches.Count - 1
            If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
            GetFromFromHeader = objRegM(0).submatches(i)
            Exit For
            End If
            Next i
        Else
            GetFromFromHeader = ""
        End If
    End With
End Function
 
 
Private Function PJ_Isembedded(ByVal pj As Attachment) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : PJ_Isembedded pour OL2010
' Author    : OLIV-
' Date      : 05/06/2015
' Version   : 2
' Purpose   : Indique 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)
 
 
    If (ATTACH_CONTENT_ID <> "" And ATTACH_FLAGS = 4) Or ATTACH_METHOD = 6 Then
        PJ_Isembedded = True
    Else
        PJ_Isembedded = False
    End If
 
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
 
 
Private Sub testGetUNC()
    MsgBox GetUNC("C:\Users\OLIV\Desktop\IconesRappelSuite.jpg", False)
End Sub
 
Private Function GetUNC(strMappedDrive As String, Optional UNClocal As Boolean) As String
'---------------------------------------------------------------------------------------
' Procedure : GetUNC
' Author    : http://pagecommunication.co.uk/2014/07/vba-to-convert-a-mapped-drive-letter-to-unc-path/
' Author    : modified by oliv-
' Date      : 20/04/2018
' Version   : 2
'---------------------------------------------------------------------------------------
'
    Dim objFso As Object
    Set objFso = CreateObject("Scripting.filesystemobject")
    Dim strDrive As String
    Dim strShare As String
    'Separated the mapped letter from
    'any following sub-folders
    Dim oDrive As Object
    strDrive = objFso.GetDriveName(strMappedDrive)
    Set oDrive = objFso.GetDrive(strDrive)
 
    'find the UNC share name from the mapped letter
    strShare = oDrive.ShareName
 
    If strShare = "" Then
        If UNClocal Then
            strShare = "\\" & Environ("computername") & "\" & Replace(strDrive, ":", "$")
        Else
            GetUNC = strMappedDrive
            Exit Function
        End If
    End If
    'The Replace function allows for sub-folders
    'of the mapped drive
    GetUNC = Replace(strMappedDrive, strDrive, strShare)
 
    Set objFso = Nothing    'Destroy the object
End Function
 
 
Private Function MEF_Octet_Short(lgValeur As Double) As String
'---------------------------------------------------------------------------------------
' Procédure : MEF_Octet_Short
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Fonction permettant un affichage en octet, kilo, mega ou giga selon valeur passée en paramètre
 
' Modif par : joe.levrai
' Date      : 25/04/2015
' Détail    : conversion des If imbriqués en une boucle While Wend avec utilisation d'un tableau d'unités
'---------------------------------------------------------------------------------------
    Dim tableau, i
    tableau = Array("Oct", "Ko", "Mo", "Go")  ' stockage des unités
 
    While (lgValeur / 1024 > 1) And i < UBound(tableau)  ' itération des divisions par 1024
        i = i + 1  ' décalage de l'unité
        lgValeur = lgValeur / 1024
    Wend
 
    MEF_Octet_Short = CStr(Round(lgValeur, 2)) & " " & tableau(i)
 
End Function
 
 
Function GetFolderByPath(ByVal FolderPath As String, Optional CreateSubFolders As Boolean) As Outlook.Folder
'---------------------------------------------------------------------------------------
' Procedure : GetFolderByPath
' Author    : Diane Poremsky
' Modified by : Oliv
' Date      : 20/10/2016
' Purpose   : Obtenir un dossier OL à partir de son chemin en créant au besoin les sous-dossiers
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim ParentFolder As Folder
 
    On Error GoTo GetFolderByPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        On Error Resume Next
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set ParentFolder = SubFolders.Item(FoldersArray(i))
            If ParentFolder Is Nothing Then
                If CreateSubFolders Then
                    Set ParentFolder = SubFolders.Add(FoldersArray(i))
                Else
                    Set GetFolderByPath = Nothing
                    Exit Function
                End If
            End If
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderByPath = Nothing
                Exit Function
            End If
            Set ParentFolder = Nothing
        Next
    End If
    Set GetFolderByPath = oFolder
    Exit Function
 
GetFolderByPath_Error:
    Set GetFolderByPath = Nothing
    Resume
    Exit Function
End Function
 
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 = trim(CheminStr)
    'MsgBox CheminStr
End Function

**tiron242** · 31/12/2018, 17h52

bonjour,
j'ai réussi à intégrer le sujet du mail dans le nom de la pj
par contre je ne sais pas ce que j'ai pu modifier de trop car les "fausses" pièces jointes sont à nouveau copiées vers le dossier choisi mais pas supprimées du mail
je voudrais donc que ce type de pj ne soient ni déplacé ni supprimé du mail d'origine

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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
Sub SaveAttachmentOLIV()
 
    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
 
 
    If MsgBox("Voulez-vous sauvegarder la(les) pièces jointe(s) ?", vbYesNo, "SAUVEGARDE DES PIECES JOINTES") = vbNo Then Exit Sub
 
    If MsgBox("La(Les) pièces jointe(s)seront supprimées du mail original et sauvegardées dans un répertoire choisi ?", vbYesNo, "SAUVEGARDE DES PIECES JOINTES") = vbNo Then Exit Sub
 
    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination:" & Chr(13) & Chr(13) & ("le dossier selectionné doit obligatoirement exister!") & Chr(13) & ("sinon la pièce jointe sera perdue!"), "SAUVEGARDE DE PIECES JOINTES", "C:\temp\pj6\")
 
    If myOrt = "" Then Exit Sub
 
    'Actions sur les objets sélectionnés
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
 
Dim Mail As Outlook.MailItem
 
    'boucle
    For Each myItem In myOlSel
 
If myItem.Class = olMail Then
 
Set Mail = myItem
 
 
Dim Expediteur
'Expediteur = Get_sender_SMTP(Mail)
 
Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=True, SuppEmbedded:=False, DirExport:="C:\temp\pj6\", Deplace:=False, _
        DossierMove:="", BodyWrite:=True, PrefixePj:=myItem.subject)
 
End If
 
 
    Next
 
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub
 
 
Sub ExportSuppression_PJ_v3(MyMail As Outlook.MailItem, Export As Boolean, Supp As Boolean, SuppEmbedded As Boolean, DirExport As String, _
Deplace As Boolean, DossierMove As String, BodyWrite As Boolean, Optional PrefixePj As String = "")
'---------------------------------------------------------------------------------------
' Procedure : ExportSuppression_PJ
' Author    : Oliv
' Date      : 21/12/2015
' Purpose   : Script pour archiver/supprimer les PJ , déplacer l'Email en ajoutant des liens hypertextes vers les fichiers archivés
'---------------------------------------------------------------------------------------
    Dim NomsPJ As String
    Dim repertoire As String
    Dim Nbpj As Integer
    Dim i As Integer, n As Integer, MemPath, PathNomExport, OuCommenceAdresse, fin, BaliseBody
    Dim pj As Attachment
    Dim Separateur As Variant
    Dim NbTiret As Integer
    Dim Link
    Dim olNS As Outlook.NameSpace
    Dim Expediteur
    Dim Erreur
 
 
    Nbpj = MyMail.Attachments.Count
    If Nbpj > 0 Then
 
 
        'on identife le format du mail
        Select Case MyMail.BodyFormat
        Case olFormatHTML:
            Separateur = "<BR>"
            NbTiret = 45
        Case olFormatPlain:
            Separateur = Chr(10)
            NbTiret = 35
        Case Else
            Separateur = " - "
            NbTiret = 50
        End Select
 
        If Export Then
            'on crée le repertoire windows où mettre les fichiers joints ##########################################################
            If Right(DirExport, 1) <> "\" Then DirExport = DirExport & "\"
            repertoire = DirExport
            If waaps_creedir(repertoire) = False Then
                Erreur = Erreur & vbCr & "repertoire : " & repertoire & " inaccessible"
                GoTo fin
            End If
        End If
 
        'on prépare le message a ajouter un Coprs du Mail
        If Export And Supp Then
            NomsPJ = IIf(Nbpj = 1, "Pièce jointe exportée et supprimée", "Pièces jointes exportées et supprimées") & " du message initial : " & Separateur & String(NbTiret, "-")
        ElseIf Export Then
            NomsPJ = IIf(Nbpj = 1, "Pièce jointe exportée", "Pièces jointes exportées") & " du message initial : " & Separateur & String(NbTiret, "-")
        ElseIf Supp Then
            NomsPJ = IIf(Nbpj = 1, "Pièce jointe supprimée", "Pièces jointes supprimées") & " du message initial : " & Separateur & String(NbTiret, "-")
        Else
            GoTo deplacement
        End If
 
 
 
        Dim TypeAtt
        'on traite les pj
        For i = Nbpj To 1 Step -1
            Set pj = MyMail.Attachments(i)
            Link = ""
            'vérification si c'est une  PJ  Embedded
            TypeAtt = PJ_Isembedded(pj)
 
            If TypeAtt = False Or SuppEmbedded Then
                n = 1
                MemPath = remplaceCaracteresInterdit(PrefixePj & "¤" & pj.FileName)
                PathNomExport = MemPath
                If Export Then
                    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
 
 
                    If MyMail.BodyFormat = olFormatHTML Then
                        Link = " <a href=""file:///" & GetUNC(repertoire & PathNomExport) & """>" & PathNomExport & "</a>"
                    Else
                        Link = "file:///" & GetUNC(repertoire & PathNomExport)
                    End If
 
                End If
 
                NomsPJ = NomsPJ & Separateur & " - " & pj.FileName & "| " & MEF_Octet_Short(pj.Size) & " -->" & Link
 
                If Supp Then
                    pj.Delete
                End If
            End If
        Next i
 
        If BodyWrite Then
            Select Case MyMail.BodyFormat
            Case olFormatHTML:
 
                OuCommenceAdresse = InStr(1, MyMail.HTMLBody, "<BODY", vbTextCompare)
                If OuCommenceAdresse > 0 Then
                    fin = InStr(OuCommenceAdresse + 5, MyMail.HTMLBody, ">") + 1
                    BaliseBody = Mid(MyMail.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
 
                    MyMail.HTMLBody = Replace(MyMail.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & "</font><BR>" _
                                                                         & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
                Else: MyMail.HTMLBody = "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & _
                                        "</font><BR>" & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & MyMail.HTMLBody
 
                End If
            Case Else
                MyMail.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & MyMail.Body
 
       ' With MyMail
       '.BodyFormat = olFormatHTML                           'définition du format du mail, ici HTML
       '.HTMLBody = strBody                                  'chargement du fichier HTML en tant que coprs du message
       '.Display                                             'affichage du mail
        'End With
 
            End Select
 
        End If
 
        'ICI on applique divers traitements sur le mail d'origine
        'drapeau vert
        MyMail.FlagIcon = olGreenFlagIcon
 
        'Marque lu
        MyMail.UnRead = False
 
        'format mail html
        MyMail.BodyFormat = olFormatHTML
 
        'Sauvegarde
        MyMail.Save
 
deplacement:
        'on déplace le mail vers un dossier outlook
        If Deplace Then
            Dim myDestFolder As Outlook.MAPIFolder
' on cherche le dossier et on essaye  de le creér
 
           Set myDestFolder = GetFolderByPath(DossierMove, True)
            If Not myDestFolder Is Nothing Then
                MyMail.Move myDestFolder
            Else
                Erreur = Erreur & vbCr & "Email non déplacé :" & DossierMove & " Dossier non trouvé"
            End If
        End If
    End If
    Set MyMail = Nothing
    Set olNS = Nothing
fin:
 
    If Erreur <> "" Then
        MsgBox Erreur, vbCritical, "Des erreurs se sont produites !"
    End If
End Sub
 
 
 
 
 
 
 
Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = Oitem.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem)
 
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress
End Function
 
Function GetFromFromHeader(objMail As Outlook.MailItem) As String
'---------------------------------------------------------------------------------------
' Procedure : GetToFromHeader
' Author    : OLIV- from original code brettdj
' Date      : 04/06/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objRegex As Object
    Dim objRegM As Object
    Dim MailHeader As String
    Dim ExtractText As String
    Dim i
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
    MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
 
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .ignorecase = True
        .Pattern = "(\n)From:.*<(.+)>"
        If .test(MailHeader) Then
            Set objRegM = .Execute(MailHeader)
            For i = 0 To objRegM(0).submatches.Count - 1
            If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
            GetFromFromHeader = objRegM(0).submatches(i)
            Exit For
            End If
            Next i
        Else
            GetFromFromHeader = ""
        End If
    End With
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
 
 
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
 
 
Private Sub testGetUNC()
    MsgBox GetUNC("C:\Users\OLIV\Desktop\IconesRappelSuite.jpg", False)
End Sub
 
Private Function GetUNC(strMappedDrive As String, Optional UNClocal As Boolean) As String
'---------------------------------------------------------------------------------------
' Procedure : GetUNC
' Author    : http://pagecommunication.co.uk/2014/07/vba-to-convert-a-mapped-drive-letter-to-unc-path/
' Author    : modified by oliv-
' Date      : 20/04/2018
' Version   : 2
'---------------------------------------------------------------------------------------
'
    Dim objFso As Object
    Set objFso = CreateObject("Scripting.filesystemobject")
    Dim strDrive As String
    Dim strShare As String
    'Separated the mapped letter from
    'any following sub-folders
    Dim oDrive As Object
    strDrive = objFso.GetDriveName(strMappedDrive)
    Set oDrive = objFso.GetDrive(strDrive)
 
    'find the UNC share name from the mapped letter
    strShare = oDrive.ShareName
 
    If strShare = "" Then
        If UNClocal Then
            strShare = "\\" & Environ("computername") & "\" & Replace(strDrive, ":", "$")
        Else
            GetUNC = strMappedDrive
            Exit Function
        End If
    End If
    'The Replace function allows for sub-folders
    'of the mapped drive
    GetUNC = Replace(strMappedDrive, strDrive, strShare)
 
    Set objFso = Nothing    'Destroy the object
End Function
 
 
Private Function MEF_Octet_Short(lgValeur As Double) As String
'---------------------------------------------------------------------------------------
' Procédure : MEF_Octet_Short
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 25/04/2008
' Détail    : Fonction permettant un affichage en octet, kilo, mega ou giga selon valeur passée en paramètre
 
' Modif par : joe.levrai
' Date      : 25/04/2015
' Détail    : conversion des If imbriqués en une boucle While Wend avec utilisation d'un tableau d'unités
'---------------------------------------------------------------------------------------
    Dim tableau, i
    tableau = Array("Oct", "Ko", "Mo", "Go")  ' stockage des unités
 
    While (lgValeur / 1024 > 1) And i < UBound(tableau)  ' itération des divisions par 1024
        i = i + 1  ' décalage de l'unité
        lgValeur = lgValeur / 1024
    Wend
 
    MEF_Octet_Short = CStr(Round(lgValeur, 2)) & " " & tableau(i)
 
End Function
 
 
Function GetFolderByPath(ByVal FolderPath As String, Optional CreateSubFolders As Boolean) As Outlook.Folder
'---------------------------------------------------------------------------------------
' Procedure : GetFolderByPath
' Author    : Diane Poremsky
' Modified by : Oliv
' Date      : 20/10/2016
' Purpose   : Obtenir un dossier OL à partir de son chemin en créant au besoin les sous-dossiers
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim ParentFolder As Folder
 
    On Error GoTo GetFolderByPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        On Error Resume Next
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set ParentFolder = SubFolders.Item(FoldersArray(i))
            If ParentFolder Is Nothing Then
                If CreateSubFolders Then
                    Set ParentFolder = SubFolders.Add(FoldersArray(i))
                Else
                    Set GetFolderByPath = Nothing
                    Exit Function
                End If
            End If
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderByPath = Nothing
                Exit Function
            End If
            Set ParentFolder = Nothing
        Next
    End If
    Set GetFolderByPath = oFolder
    Exit Function
 
GetFolderByPath_Error:
    Set GetFolderByPath = Nothing
    Resume
    Exit Function
End Function
 
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 = Trim(CheminStr)
    'MsgBox CheminStr
End Function

**Oliv-** · 02/01/2019, 10h41

Bonjour,
Il n'y a pas de raison que les "fausses pj" soient enregistrées sur le disque, mais cela peut être exceptionnel, certaines PJ sont des fois mal qualifiées.

**tiron242** · 02/01/2019, 18h52

bonjour,
effectivement cela fonctionne!!
super
j'ai en plus créé une catégorie(pièces détachées) :

Nom : capt.jpg
Affichages : 832
Taille : 23,7 Ko

par contre est-il possible de pouvoir choisir le dossier outlook où sera déplacé le mail et pas simplement dans un dossier par défaut?...je pousse le bouchon!

merci
bonne fin de journée

**Oliv-** · 02/01/2019, 21h16

Bonsoir,
Pour déplacer le mail dans un dossier OUTLOOK à la fin du traitement il faut dans la fonction, passer les paramètres Deplace:=True et renseigner le path complet du dossier, DossierMove:="" comme cela

Code VBA :

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

1
2
3
4
5
6
7
8
9
10
11
  Dim olNS As Outlook.NameSpace
             Dim olFolder As Outlook.Folder
 
    Set olNS = Application.GetNamespace("MAPI")
 
 
    'soit on le choisi
    Set olFolder = olNS.PickFolder
 
Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=True, SuppEmbedded:=False, DirExport:="C:\temp\pj6\", Deplace:=True, _
        DossierMove:=olFolder.FolderPath, BodyWrite:=True, PrefixePj:=myItem.subject)