Macro suppression de pièces jointes

**Julien80L** · 04/04/2015, 23h33

Bonjour,

J'utilise Outlook 2010 au travail et je cherche une macro permettant de supprimer les pièces jointes d'un mail.

Parmi les différentes propositions que l'on peut trouver sur les forums, j'ai trouvée celle ci-dessous sur faq-outlook
Je la trouve particulièrement intéressante car elle permet de remplacer les PJ supprimées par un fichier texte contenant la liste des PJ supprimées. Cela permet de conserver la possibilité de tri par la présence de PJ.

Toutefois cette macro nécessite la présence de la librairie Microsoft CDO 1.21 qui n'est plus compatible avec Outlook 2010.

http://support.microsoft.com/fr-fr/kb/2028411/fr

Quelqu'un aurait il une proposition pour adapter cette macro en restaurant la compatibilité avec Outlook 2010 ?
Merci d'avance pour vos propositions ou tout bon conseil.

Les 2 fonctions suivantes sont nécessaires :

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
 
Public Function TypePJ(ByVal strEntryID As String, attindex As Integer) As Variant
' Ecrit par Olivier CATTEAU
' Nécessite la référence à la librairie Microsoft CDO 1.21
 
' Pour Outlook 2007 il faut le télécharger là :
' http://www.microsoft.com/downloads/details.aspx?familyid=2714320d-c997-4de1-986f-24f081725d36&displaylang=en
 
' Le retour est <>"" si la PJ est un objet inséré dans le mail HTML
 
Dim oSession As MAPI.Session
  ' CDO objects
  Dim oMsg As MAPI.Message
  Dim oAttachs As MAPI.Attachments
  Dim oAttach As MAPI.Attachment
 
  ' initialize CDO session
  On Error Resume Next
  Set oSession = CreateObject("MAPI.Session")
  oSession.Logon "", "", False, False
 
  ' get the message created earlier
  Set oMsg = oSession.GetMessage(strEntryID)
  ' set properties of the attached graphic that make
  ' it embedded and give it an ID for use in an  tag
  Set oAttachs = oMsg.Attachments
  Set oAttach = oAttachs.Item(attindex)
  Dim strCID As String
  strCID = oAttach.Fields(&H3712001E)
 
  TypePJ = strCID
  Set oMsg = Nothing
  oSession.Logoff
  Set oSession = Nothing
 
End Function

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
 
Public Function MailActif() As MailItem
' Ecrit par Fabrice NEBBIA avec l'aide de Géo et Olivier CATTEAU
 
' Renvoie le mail ouvert
' Si aucun élément n'est ouvert ou s'il ne s'agit pas d'un mail
' Un message l'indique et la valeur renvoyée est Nothing
 
    Dim Inspecteur As Inspector
 
    Set MailActif = Nothing
 
    Set Inspecteur = ActiveInspector
 
    ' y a t-il un affichage d'item actif
    If Inspecteur Is Nothing Then
        MsgBox "Aucun élément n'est ouvert actuellement", vbCritical
        Exit Function
    End If
 
    'Cet affichage concerne-t-il un courrier ?
On Error Resume Next
    Set MailActif = Inspecteur.CurrentItem
    If Err <> 0 Then
    MsgBox "L'élément en cours n'est pas un e-mail", vbCritical
    Exit Function
    End If
On Error GoTo 0
 
End Function

Et la macro elle même à lancer depuis le mail ouvert:

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
 
Public Sub Suppression_PJ_originales()
' Ecrit par Fabrice NEBBIA
' Grace au travail de Géo, Anacoluthe, Isabelle Prawitz et Olivier CATTEAU
 
' Fonction à ajouter dans le projet :
'   Public Function MailActif() As MailItem
'   Public Function TypePJ(ByVal strEntryID As String, attindex As Integer) As Variant
 
' Supprime les PJ du mail actif avec une mention pour mémoire selon 2 formes
' Mention insérée dans le corps du message
' et/ou insertion d'un fichier texte joint : permet de maintenir le trombone dans la liste des mails
 
    Dim Courrier As MailItem
    Dim NomsPJ As String
 
    Dim NbPJ As Integer
    Dim i As Integer
    Dim PJ As Attachment
    Dim Separateur As Variant 
    Dim NbTiret As Integer
 
    Dim f As Integer
    Dim Fichier As String
    Dim ListePJ As String
 
    Dim ListeEnPJ, InsertMention As Boolean
 
    Set Courrier = MailActif
    If Courrier Is Nothing Then Exit Sub
 
    NbPJ = Courrier.Attachments.Count
    If NbPJ = 0 Then
        MsgBox "Le messages en cours ne contient pas de pièce jointe.", vbInformation
        Exit Sub
    End If
 
    ' Decommenter pour ajouter une confirmation si on supprime les suivantes
    'If MsgBox("Vous êtes sur le point de supprimer les pièces jointes de ce message." & vbCrLf & "Continuer ?", _
    '    vbYesNo + vbQuestion, "Suppression des pièces jointes...") = vbNo Then Exit Sub
 
    ListeEnPJ = True
    'Commenter ou supprimer pour ne pas poser la question
    If MsgBox("Ajouter un fichier texte mentionnant la liste des pièces jointes intiales.", _
        vbYesNo + vbQuestion, "Ajout fichier joint...") = vbNo Then ListeEnPJ = False
 
    InsertMention = True
    'Commenter ou supprimer pour ne pas poser la question
    If MsgBox("Mentionner la liste des pièces jointes dans le corps du message ?", _
        vbYesNo + vbQuestion, "Mentionner les pièces jointes dans le message...") = vbNo Then InsertMention = False
 
    If ListeEnPJ = False And InsertMention = False Then
        MsgBox "Opération annulée." & vbCrLf & "Les pièces jointes n'ont pas été supprimées", vbInformation, "Opération annulée..."
        Exit Sub
    End If
 
    Select Case Courrier.BodyFormat
        Case olFormatHTML:
            Separateur = "<br/>"
            NbTiret = 45
        Case olFormatPlain:
            Separateur = Chr(10)
            NbTiret = 35
        Case Else
            Separateur = " - "
            NbTiret = 50
    End Select
 
    NomsPJ = IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & " du message initial : " & Separateur & String(NbTiret, "-")
    ListePJ = IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & " du message initial :" & vbCrLf _
    & String(IIf(NbPJ = 1, 33, 35), "-") & vbCrLf & vbCrLf
 
    For i = NbPJ To 1 Step -1
        Set PJ = Courrier.Attachments(i)
        PJType = TypePJ(Courrier.EntryID, PJ.Index)
        If PJType = "" Then
            NomsPJ = NomsPJ & Separateur & "- " & PJ.FileName
            ListePJ = ListePJ & "- " & PJ.FileName & vbCrLf
            PJ.Delete
        End If
 
    Next
 
    If Not ListeEnPJ Then GoTo InsererMention
 
    If Dir("c:\temp\", vbDirectory) = "" Then
        MsgBox "Le dossier temporaire ""c:\temp\"" n'existe pas." & vbCrLf & "Procédure annulée.", vbCritical
        Exit Sub
    End If
 
    Fichier = "c:\temp\" & IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & ".txt"
 
    If Dir(Fichier) <> "" Then
        If MsgBox("Le fichier """ & Fichier & """ existe déjà." & vbCrLf & "Ecraser le fichier ?", vbQuestion Or vbYesNo) = vbNo Then
            MsgBox "Procédure annulée.", vbInformation
            Exit Sub
        End If
    End If
 
    f = FreeFile
    Open Fichier For Output As #f
        Print #f, ListePJ
    Close #f
 
    Courrier.Attachments.Add Fichier
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fic = fs.GetFile(Fichier)
    fic.Delete
    Set fic = Nothing
    Set fs = Nothing
 
InsererMention:
    If InsertMention Then
 
        Select Case Courrier.BodyFormat
            Case olFormatHTML:
                Courrier.HTMLBody = "<font style='font-family: Arial ;font-size: 8pt ;color:#808080;font-style: italic;'>" _
                    & NomsPJ & "</font><br/>" & "<font style='font-family: Arial ;font-size: 8pt ;color:#808080;font-style: italic;'>" _
                    & String(NbTiret, "-") & "</font><br/><br/>" & Courrier.HTMLBody
            Case Else
                Courrier.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & Courrier.Body
 
        End Select
    End If
 
    ' La demande d'enregistrement est effectuées à la fermeture du mail
    ' Décommenter la ligne suivante pour enregistrer automatiquement les modifs sans demande de confirmation
    'Courrier.Save
 
End Sub