Par défaut Export pièce jointe outlook avec adresse mail associée depuis dossier spécifique

**michafoule** · 21/04/2016, 17h08

Bonjour,

Je recopié votre code que j'ai trouvé sur une autre conversation, et je souhaiterais extraire seulement les pièce jointe présente dans le dossier "Redac" commen mentionné dans le code plus bas. Et le point qui me semble plus compliqué, c est que j'aimerais que les pièces jointes aient l'adresse de leur expéditeur en tant que nom de fichier , est-ce possible ? Merci beaucoup !
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
' ---
' EXTRACTION DE PIECES JOINTES OUTLOOK
' ---
'
Sub SaveAttachments( _
  ByVal strTargetFolder As String, _
  Optional ByVal blnIncludeSubFolders As Boolean = False)
  
  ' Quelques variables...
  Dim olApp As Outlook.Application
  Dim ns As Outlook.NameSpace
  Dim fld As Outlook.MAPIFolder
  
  ' Vérifier si le dossier de destination existe bien
  If Dir(strTargetFolder, vbDirectory) = "" Then
    MsgBox "Le dossier destination n'existe pas !", vbExclamation
    Exit Sub
  End If
  'strTargetFolder = AddBackslash(strTargetFolder)
  
  ' Démarrer Outlook
  Set olApp = New Outlook.Application
  
  ' Pointer sur la boîte de réception
  Set ns = olApp.GetNamespace("MAPI")
  Set fld = ns.GetDefaultFolder(olFolderRedac) je souhaite exporter les pièce jointe de ce dossier rédac : Fouleurs/Redac
  
  ' Extraire tous les messages du dossier
  SaveFolderAttachments fld, strTargetFolder, blnIncludeSubFolders
  
  Set fld = Nothing
  Set ns = Nothing
  olApp.Quit
  Set olApp = Nothing
End Sub

' ---
' EXTRACTION DES PIECES JOINTES D'UN DOSSIER
' ---
'
Sub SaveFolderAttachments( _
  fld As Outlook.MAPIFolder, _
  strTargetFolder As String, _
  Optional ByVal blnIncludeSubFolders As Boolean = False)

  Dim mi As Outlook.MailItem
  Dim att As Outlook.Attachment
  Dim strFile As String
  
  ' Debug
  Debug.Print "---"
  Debug.Print "DOSSIER : " & fld.Name
  Debug.Print "---"
  
  ' Parcourir tous les messages
  For Each mi In fld.Items
    If mi.Attachments.Count > 0 Then
      ' Pour info...
      Debug.Print mi.Subject
      
      For Each att In mi.Attachments
        strFile = FilenameInc(strTargetFolder & att.FileName)
        
        ' Sauvegarder la pièce jointe sous son nom original
        ' ou avec un nom incrémenté en cas de doublons
        att.SaveAsFile strFile
        Debug.Print "  -> " & strFile
      Next
    End If
  Next
  
  ' Si nécessaire, effectuer le même traitement
  ' sur les sous-dossiers
  If blnIncludeSubFolders Then
    Dim subfld As Outlook.MAPIFolder
    For Each subfld In fld.Folders
      SaveFolderAttachments subfld, strTargetFolder, blnIncludeSubFolders
    Next
  End If
End Sub
' ---
' AJOUT D'UN  EN FIN DE CHEMIN
' ---
' Entrée : strFolder <- Chemin à retraiter.
' Sortie : Chemin avec  ajouté à la fin si nécessaire.
'
Function AddBackslash( _
  ByVal strFolder As String) As String
  
  strFolder = Trim(strFolder)
  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  AddBackslash = strFolder
End Function

**Oliv-** · 21/04/2016, 17h43

Bonjour,

A priori ce code est de HERVÉ INISAN.

Vous souhaitez juste extraire les pj de ce dossier Redac ou également les supprimer du Mail ?

Le dossier Redac est t'il au même niveau que Boite de reception ou est-ce un sous dossier ?

LE code sera exécuté à partir de Outlook ou d'un autre programme ?

**michafoule** · 21/04/2016, 18h28

Vous souhaitez juste extraire les pj de ce dossier Redac ou également les supprimer du Mail ?
- je souhaite juste extraire les pj vers un dossier, pas besoin de les supprimer.

Le dossier Redac est t'il au même niveau que Boite de reception ou est-ce un sous dossier ?
C'est un sous dossier de "Fouleurs" qui lui est au même niveau que la boite de réception.

LE code sera exécuté à partir de Outlook ou d'un autre programme ?

Pour l'instant mon code est lancé à partir du VBA d'outlook.

Merci pour votre aide.

Concernant le nom des fichiers exportés : leur donner l'adresse mail de l'expéditeur en tant que nom de fichier, avez vous une solution pour ceci ?

Merci beaucoup en tout cas !

**Oliv-** · 21/04/2016, 18h39

voici un code qui devrait faire l'affaire.
c'est plus complexe mais cela offre plusieurs possibilité voir cet article concernant les options de ExportSuppression_PJ

Il permet de choisir le dossier de départ

Il faudra changer dans ExportSuppression_PJ_V2 le dossier d'export.

A mettre dans un Module

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
Option Explicit
 
 
Sub Lance_Traitement()
'---------------------------------------------------------------------------------------
' Procedure : Lance_Traitement
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim OL As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
 
    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")
 
    'soit on connait le dossier
    'Set olFolder = olNS.GetDefaultFolder(olFolderInbox).folders
 
    'soit on le choisi
    Set olFolder = olNS.PickFolder
 
    ' on met false pour ne traiter que le dossier principal
    Call ProcessFolders(olFolder, False)
    MsgBox "Traitement terminé"
End Sub
 
Sub ProcessFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : Oliv'
' Date      : 12/02/2016
' Purpose   : Traitement récursif sur les dossiers OUTLOOK
'---------------------------------------------------------------------------------------
'
    Dim objFolder As Outlook.MAPIFolder
    Dim objitem As Object
 
    'Dim objItem As Object
    'On Error Resume Next
 
    ' do something specific with this folder
    Debug.Print StartFolder.FolderPath, StartFolder.Items.Count
    Debug.Print
    If StartFolder.DefaultItemType = olMailItem Then
        '  ICI LE TRAITEMENT POUR CHAQUE DOSSIER
        ' Call ProcessThisFolder(StartFolder)
    End If
 
    ' process all the items in this folder
    'ICI LE TRAITEMENT POUR TOUS LES ELEMENTS DU DOSSIER
 
    Dim i
    For i = StartFolder.Items.Count To 1 Step -1
        Set objitem = StartFolder.Items(i)
        Call ProcessThisItem(objitem)
    Next i
 
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If SubFolder Then
        For Each objFolder In StartFolder.folders
            Call ProcessFolders(objFolder, SubFolder)
        Next
    End If
 
    Set objFolder = Nothing
End Sub
 
 
Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    If objitem.Class = olMail Then
        Dim MyMail As Outlook.MailItem
        Set MyMail = objitem
 
       'ici le code d'export ajuster le dossier de destination
        ExportSuppression_PJ_V2 MyMail, True, False, False, "C:\temp\extractionPJ\", False, "", False
    End If
 
 
End Sub
 
 Sub ExportSuppression_PJ_V2(MyMail As Outlook.MailItem, Export As Boolean, Supp As Boolean, SuppEmbedded As Boolean, DirExport As String, Deplace As Boolean, DossierMove As String, info As Boolean)
'---------------------------------------------------------------------------------------
' 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
        Expediteur = Get_sender_SMTP(MyMail)
 
        '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(Expediteur & "¤" & 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 info 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
 
        End Select
 
        End If
 
        'ICI on applique divers traitements sur le mail d'origine
        'drapeau vert
        MyMail.FlagIcon = olGreenFlagIcon
 
        'Marque lu
        MyMail.UnRead = False
 
        'Sauvegarde
        MyMail.Save
 
deplacement:
        'on déplace le mail vers un dossier outlook
        If Deplace Then
            Dim myDestFolder As Outlook.MAPIFolder
 
            Set myDestFolder = GetFolderByPath(DossierMove)
            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 = oItem.SenderEmailAddress
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 FileSystemObject, 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\OCTU\Desktop\OUTILS\NanoVB6\PROJETS\TestàpartirdeOL2010\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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objFso As FileSystemObject
    Set objFso = New FileSystemObject
    Dim strDrive As String
    Dim strShare As String
    'Separated the mapped letter from
    'any following sub-folders
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
    strShare = objFso.Drives(strDrive).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) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
 
    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
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.folders
            Set SubFolders = oFolder.folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderByPath = Nothing
            End If
        Next
    End If
    Set GetFolderByPath = oFolder
    Exit Function
 
GetFolderByPath_Error:
    Set GetFolderByPath = Nothing
    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 = CheminStr
    'MsgBox CheminStr
End Function

**michafoule** · 22/04/2016, 15h13

Bonjour,

Merci pour votre aide.

J'ai bien modifié mon dossier d'export ExportSuppression_PJ_V2 .

En revanche je ne comprend pas comment/ou choisir le dossier concerné dans OUTLOOK.

De plus, quand j'essaye de lancer la macro, un message d'erreur apparaît :
Les macros de ce projet sont désactivés, message qui n’apparaissait pas avant, je pouvais exporter les pièces jointe vers mon fichier, mais il ne choisissait pas le sous dossier voulu :Fouleur/Redac

Merci pour votre aide,

**Oliv-** · 22/04/2016, 15h24

Bonjour,
Quand tu lances Outlook il faut activer les macros (ou contenu)

Le choix du dossier outlook se fait de façon dynamique quand tu lances Lance_Traitement

la fonction PickFolder t'ouvre une boite de dialogue pour le choisir.

**michafoule** · 22/04/2016, 15h29

Bonjour,

Merci pour ces informations.
J'ai bien activé toutes les macros dans les options.
Or le message d'erreur persiste, et quand je clique sur la macro projet1 lance_traitement rien ne se passe :/

Merci,

**Oliv-** · 22/04/2016, 16h35

Ce message là ?

"Les macros de ce projet sont désactivés.."

dans les paramètres de sécurité (ol2010) : Fichier/options/centre de gestion de la confidentialité
tu dois avoir

Nom : PARAMETRE_MACROS_OL2010.png
Affichages : 623
Taille : 24,0 Ko

Nom : PARAMETRE_MACROS_OL2010.png
Affichages : 623
Taille : 24,0 Ko

**michafoule** · 22/04/2016, 18h01

Oui c'est ce message la, et c'est exactement ce que j'ai fait, ref à ton screen shot .

**Oliv-** · 22/04/2016, 19h42

Il faut relancer outlook

**michafoule** · 25/04/2016, 10h54

Bonjour, en effet, cela marche maintenant, et je peux choisir le dossier à exporter. En revanche votre code ne fonctionne pas totalement, j'ai mis les lignes concerné en couleur :

Erreur de compilation :
Type défini par l'utilisateur non défini :

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
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 FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r
    Dim rep, REP_TOP

(tout le code est-il nécéssaire ? la partie choisir mon dossier à exporter me suffit, je voudrais juste donner le nom de l'expéditeur à ces pièces jointes )

Merci beaucoup !!

**Oliv-** · 25/04/2016, 12h05

Bonjour,

Essaye en remplaçant par

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

Il peut y avoir du code superflu, selon les options choisies, mais en principe si c'est là c'est que cela à de l'importance, utilise le mode pas à pas F8 pour voir le déroulé.

**michafoule** · 25/04/2016, 17h56

Merci,ca marche pour cette partie nous passons à l'étape suivante du code .. ahah

, comment faire pour résoudre celle ci ? Merci beaucoup !!!

Code :

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

1
2
3
4
5
6
7
8
9
10
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objFso As FileSystemObject

**Oliv-** · 26/04/2016, 10h16

Bonjour,
en fait ce n'est pas un Bug c'est une référence manquante et c'est la même que la précédente (Microsoft Scripting Runtime).

Soit on ajoute la référence (early binding) soit on modifie le code pour faire du late binding.

Avec le second choix

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
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    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
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
    strShare = objFso.Drives(strDrive).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

**michafoule** · 26/04/2016, 11h44

Merci pour ces informations, je suis assez débutant en code.

j'ai bien appliqué votre nouveau code, il y un debogage a effectuer dans une ligne de votre code :

Merci beaucoup !

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
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    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
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
    strShare = objFso.Drives(strDrive).ShareName

**Oliv-** · 26/04/2016, 13h00

C'est étrange !

essaye avec 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
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    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
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
     Set dc = objFso.Drives
    strShare = objFso.Drives(UCase(strDrive)).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

**michafoule** · 26/04/2016, 14h28

Merci,

Quand je copie ce code, le traitement marche quand je selectionne le dossier "Fouleur" qui est mon dossier racine. Mais rien ne s'exporte car il n'y a rien dans ce dossier, mais dans le sous-dossier : "Redac"
Quand je selectionne celui-ci le code bug au niveau "dc=" merci !

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
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    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
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
     Set dc = objFso.Drives

**Oliv-** · 26/04/2016, 15h06

Je dois tout deviner avec toi , si tu mettais le message d'erreur ce serait plus simple ::
avec ceci

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
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      : 21/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    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
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
    ' Set dc = objFso.Drives
    strShare = objFso.Drives(UCase(strDrive)).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

**michafoule** · 26/04/2016, 16h07

Excusez moi. Voici l'erreur : erreur de compilation / Sub ou function non défini au niveau de : MEF_Octet_Short

Merci !!!

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
 Sub ExportSuppression_PJ_V2(MyMail As Outlook.MailItem, Export As Boolean, Supp As Boolean, SuppEmbedded As Boolean, DirExport As String, Deplace As Boolean, DossierMove As String, info As Boolean)
'---------------------------------------------------------------------------------------
' 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
        Expediteur = Get_sender_SMTP(MyMail)
 
        '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(Expediteur & "¤" & 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 info 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
 
        End Select
 
        End If
 
        'ICI on applique divers traitements sur le mail d'origine
        'drapeau vert
        MyMail.FlagIcon = olGreenFlagIcon
 
        'Marque lu
        MyMail.UnRead = False
 
        'Sauvegarde
        MyMail.Save
 
deplacement:
        'on déplace le mail vers un dossier outlook
        If Deplace Then
            Dim myDestFolder As Outlook.MAPIFolder
 
            Set myDestFolder = GetFolderByPath(DossierMove)
            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 = oItem.SenderEmailAddress
End Function

**Oliv-** · 26/04/2016, 16h20

Quand tu as remplacé le code de GetUNC
tu as du supprimer la fonction MEF_Octet_Short qui était juste après

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

Par défaut Export pièce jointe outlook avec adresse mail associée depuis dossier spécifique

VBA Outlook

Discussions similaires

Partager

Partager