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
| '*************** Et la procédure à lancer depuis le mail ouvert
Public Sub Supprime_PJ()
' Ecrit par Fabrice NEBBIA
' Grace au travail de Géo, Anacoluthe, Isabelle Prawitz et Olivier CATTEAU
' Supprime les PJ du mail actif et insère le nom des PJ dans le corps du message
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
If Application.ActiveInspector Is Nothing Then Exit Sub
If MsgBox("Cette macro va supprimer les pièces jointes du mail et les remplacer par leur nom", _
vbYesNo + vbQuestion, "Etes vous sûr de vouloir exécuter cette macro ?") = vbNo Then Exit Sub
Set Courrier = ActiveInspector.CurrentItem
If Courrier Is Nothing Then Exit Sub
Select Case Courrier.BodyFormat
Case olFormatHTML:
Separateur = "<BR>"
NbTiret = 45
Case olFormatPlain:
Separateur = Chr(10)
NbTiret = 35
Case Else
Separateur = " - "
NbTiret = 50
End Select
NbPJ = Courrier.Attachments.Count
If NbPJ = 0 Then
MsgBox "Le messages en cours ne contient pas de pièce jointe"
Exit Sub
End If
NomsPJ = IIf(NbPJ = 1, "Pièce jointe supprimée", "Pièces jointes supprimées") & " du message initial après lecture: " & Separateur & String(NbTiret, "-")
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
pj.Delete
Else
If MsgBox(pj.FileName & ": est une image ou un élément incorporé dans le corps du mail", vbYesNo, "Supprimer cette élément ?") = vbYes Then
NomsPJ = NomsPJ & Separateur & "- " & pj.FileName & "(incorporé)"
pj.Delete
End If
End If
Next
Select Case Courrier.BodyFormat
Case olFormatHTML:
OuCommenceAdresse = InStr(1, Courrier.HTMLBody, "<BODY", vbTextCompare)
If OuCommenceAdresse > 0 Then
fin = InStr(OuCommenceAdresse + 5, Courrier.HTMLBody, ">") + 1
BaliseBody = Mid(Courrier.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
Courrier.HTMLBody = Replace(Courrier.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: Courrier.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>" & Courrier.HTMLBody
End If
Case Else
Courrier.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & Courrier.Body
End Select
' A activer pour enregistrer automatiquement les modifs
'Courrier.Save
End Sub
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
' Le retour est <>"" si la PJ est la PJ zest un objet inséré dans le mail HTML
Dim oSession As Object 'MAPI.Session
' CDO objects
Dim oMsg As Object 'MAPI.Message
Dim oAttachs As Object 'MAPI.Attachments
Dim oAttach As Object '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 <IMG> 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 |
Partager