Oliv-

Bonjour,
Voici un code utilisable à partir d'une macro ou d'un règle dans OUTLOOK

Elle permet d'opérer sur le mail passé en paramètres les action suivantes :

Code VB :

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

Sub ExportSuppression_PJ_v3(MyMail As Outlook.MailItem, Export As Boolean, Supp As Boolean, SuppEmbedded As Boolean, DirExport As String, Deplace As String, DossierMove As String, BodyWrite As Boolean)

-Export des pièces jointes dans un répertoire (Windows) -->Export :=true avec renseignement du répertoire de destination DirExport ="c:\temp\
-Suppression de Pièces jointes du Mail -->Supp:=true
-Ignore les pièces jointes incorporées dans le corps du Mail. -->SuppEmbedded :=false
-Ajout dans le coprs du Mail, du nom des pièces jointes traitées, de leur taille et lien hypertext vers le fichier exporté. -->info :=True
-Classement du mail dans un Dossier OUTLOOK différent -->Deplace:=true en renseignant le dossier DossierMove ="C:\temp\"
-Préfixe devant le nom des picèces jointes : PrefixePj:="cequejeveux"
-Ajouter l'information dans le mail d'origine

-Flag du mail
-Mail passé en lu.

Une macro pour le lancer sur le mail actif :

Code vb :

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

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Test_ExportSuppression_PJ()
Dim Mail As Outlook.MailItem
Set Mail= ActiveInspector.CurrentItem
 
 
Dim  Expediteur 
Expediteur = Get_sender_SMTP(Mail)
 
Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:="c:\temp\newexportmsg", Deplace:=True, _
        DossierMove:="\\maboite\Traitements\EXPORT", BodyWrite:=True, PrefixePj:=Expediteur)
 
End Sub

Un script pour l'utiliser avec une "règle"
Attention Pour Utiliser l'action "Exécuter un script" avec les règles il faut modifier le registre.

Outlook 2016
HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security
DWORD: EnableUnsafeClientMailRules
Value: 1

Outlook 2013
HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Security
DWORD: EnableUnsafeClientMailRules
Value: 1

Outlook 2010
HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Outlook\Security
DWORD: EnableUnsafeClientMailRules
Value: 1

Code VB :

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

1
2
3
4
5
6
7
Sub regle_exportPJ(Mail As Outlook.MailItem)
 
Dim  Expediteur 
Expediteur = Get_sender_SMTP(Mail)
 
   Call ExportSuppression_PJ_V3(Mail, True, True, False, "c:\temp\newexportmsg", True, "\\maboite\Boîte de réception\Test", True, Expéditeur) 
End Sub

Une boucle sur les Emails de la boite de réception dont le sujet comporte un mot (ici IDFC)

Code VB :

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
Sub Find_Items_and_export_Att()
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim i, filtre
 
    Set myNamespace = Application.GetNamespace("MAPI")
    Set myFolder = _
            myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    filtre = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
            & Chr(34) & " ci_phrasematch " & "'IDFC'"    ' "'can''t'"
 
 
    Set myRestrictItems = myItems.Restrict(filtre)
    For i = myRestrictItems.count To 1 Step -1
        Set myItem = myRestrictItems(i)
        Dim Expediteur As String
        Expediteur = Get_sender_SMTP(myItem)
 
        Call ExportSuppression_PJ_v3(MyMail:=myItem, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:="c:\temp\newexportmsg", Deplace:=True, _
                DossierMove:="\\maboite\Traitements\EXPORT", BodyWrite:=True, PrefixePj:=Expediteur)
 
        myRestrictItems(i).Display
        Set myItem = Nothing
    Next
End Sub

Le code principal :

Code VB :

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

Les fonctions nécessaires :

Code VB :

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