R15250 [VBA] ImagesDansMessage
Publié par Oliv le Mardi 24 avril 2007 15:13
Vous devez créer un dossier sur votre disque dur ici :
c:\Pieces jointes\

Vous pouvez appeler cette Macro dans l'événement Application_NewMail pour que ce soit appliqué à l'arrivée d'un nouveau mail.


Attention cela agit sur tous les mails HTML de la boîte de réception !!!! et supprime la pj.

Cela ne gère pas non plus les doublons de nom dans le répertoire des PJ !!

Pour éviter les erreurs j'ai commenté la ligne Delete et ajouté un message de confirmation.

Sub ImagesDansMessage() Dim leMess As MailItem

Dim LItem As Object

Dim LeDoss As MAPIFolder

Dim lesItems As Items

Dim laPJ As Attachment

Dim nbAtt As Integer

Dim i As Integer

Dim NS As NameSpace

Set LeDoss = Session.GetDefaultFolder(olFolderInbox)

Set lesItems = LeDoss.Items For Each LItem In lesItems

If TypeName(LItem) = "MailItem" Then

Set leMess = LItem

nbAtt = leMess.Attachments.Count

If leMess.BodyFormat = olFormatHTML And nbAtt > 0 Then

'à commenter si vous ne voulez pas de message

Traiter = MsgBox(leMess.Subject, vbYesNoCancel, "Voulez vous traiter ce mail ?")

If Traiter = vbCancel Then Exit Sub

If Traiter <> vbNo Then


For Each laPJ In leMess.Attachments If Right(LCase(laPJ.FileName), 4) = ".jpg" Or _
Right(LCase(laPJ.FileName), 4) = "jpeg"
Or _

Right(LCase(laPJ.FileName), 4) = ".gif" Then

' *** attention Dossier à paramétrer

laPJ.SaveAsFile "C:\TEMP\pj\" & laPJ.DisplayName

' *** attention Dossier à paramétrer

leMess.HTMLBody = "<IMG alt'' hspace0 src'" & _

"C:\TEMP\pj\" & laPJ.DisplayName & _

"' alignºseline border0><br>" & _

leMess.HTMLBody

End If

Next

For i = leMess.Attachments.Count To 1 Step -1

Set laPJ = leMess.Attachments.Item(i)

If Right(LCase(laPJ.DisplayName), 4) = ".jpg" Or _
Right(LCase(laPJ.DisplayName), 4) = "jpeg" Or _

Right(LCase(laPJ.DisplayName), 4) = ".gif" Then

'en décommentant le ligne ci-dessous vous surprimez la PJ du mail.

'laPJ.Delete

End If

Next

leMess.Save

End If

End If

End If

Next

End Sub

'Fin de macro