Transferer des mails
Bonjour,
Je viens vers vous car je souhaiterai transférer mes nouveaux messages vers une autre boite mail.
Ci-dessous vous trouverai le code que j'ai entré sur la Module de Outlook mais ceci ne fonctionne pas
Sub transfemail(Mail As MailItem)
Dim MonMail As Outlook.MailItem
Dim FwEmail As Outlook.MailItem
Set MonMail = ActiveInspector.CurrentItem
Set FwEmail = MonMail.Forward
FwEmail.To = "aaa@bb.com" 'le destinataire
MonTexteEnPlus = "Rappel au message ci-dessous envoyé le " & FwEmail.LastModificationTime
Select Case FwEmail.BodyFormat
'ici on vérifie le format du message HTML OU BRUT ...
Case olFormatHTML:
OuCommenceAdresse = InStr(1, FwEmail.HTMLBody, "<BODY", vbTextCompare)
If OuCommenceAdresse > 0 Then
fin = InStr(OuCommenceAdresse + 5, FwEmail.HTMLBody, ">") + 1
BaliseBody = Mid(FwEmail.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
FwEmail.HTMLBody = Replace(FwEmail.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & MonTexteEnPlus & "</font><BR>" _
& "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
Else: FwEmail.HTMLBody = "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & liste & _
"</font><BR>" & "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & FwEmail.HTMLBody
End If
Case Else
objCurrentMessage.Body = Replace(MonTexteEnPlus, "<br>", vbCr) & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & objCurrentMessage.Body
End Select
'pour voir le mail et ou afficher la signature
FwEmail.Display
'Pour l'envoyer
' FwEmail.Send
End Sub
Merci d'avance de notre aide.