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
| Sub ScriptRepToRec(myMail As MailItem)
'---------------------------------------------------------------------------------------
' Procedure : RepToRec
' Author : Oliv'
' Date : 16/04/2008
' Purpose : script a executer avec une règle pour répondre au destinataires A
'---------------------------------------------------------------------------------------
'
Dim LaReponse As Outlook.MailItem
Dim StrID As String
Dim olNS As Outlook.NameSpace
Dim Msg As Outlook.MailItem
Dim Destinataire, liste
'ici on peut mettre des conditions
If myMail.subject = "" Then Exit Sub
Set LaReponse = myMail.Reply
'il faut supprimer les destinataires par defaut
For i = LaReponse.Recipients.Count To 1 Step -1
LaReponse.Recipients.Remove i
Next i
LaReponse.Display
For Each Destinataire In myMail.Recipients
'MsgBox destinataire
If Destinataire.Type = olTo Then
LaReponse.Recipients.add Destinataire.Address
End If
Next Destinataire
MonTexteEnPlus = "Mon message de réponse"
Select Case LaReponse.BodyFormat
'ici on vérifie le format du message HTML OU BRUT ...
Case olFormatHTML:
OuCommenceAdresse = InStr(1, LaReponse.HTMLBody, "<BODY", vbTextCompare)
If OuCommenceAdresse > 0 Then
FIN = InStr(OuCommenceAdresse + 5, LaReponse.HTMLBody, ">") + 1
BaliseBody = Mid(LaReponse.HTMLBody, OuCommenceAdresse, FIN - OuCommenceAdresse)
LaReponse.HTMLBody = Replace(LaReponse.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & MonTexteEnPlus & "</font><BR>" _
& "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
Else: LaReponse.HTMLBody = "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & liste & _
"</font><BR>" & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & LaReponse.HTMLBody
End If
Case Else
ObjCurrentMessage.Body = Replace(MonTexteEnPlus, "<br>", vbCr) & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & ObjCurrentMessage.Body
End Select
LaReponse.Display
' LaReponse.Send
End Sub |
Partager