Format de texte lors d'envois par mail en CDO.Configuration

Le
Fredo P.
Bonjour,
Peut on formater le texte en gras et/ou couleurs, le message, lors d'un
envoi automatique de courriers avec CDO.Configuration
Routine utilisée:
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object, i%, x%
Dim PlgAdr As Range
Dim strbody As String, strbody2$
Dim C As Range, D As Object
Dim Rep As Byte, Suj$, Exp$, Mbr$, Prén$, Nom$
Dim FichiersJoints As String, Fichier$, FichierList$
On Error Resume Next
Suj = InputBox("Indiquez votre Sujet", "Sujet", [D1])
[D1] = Suj
Exp = InputBox("indiquez l'expéditeur", "Expéditeur", [D2])
Rep = MsgBox("Autorisez vous l'envoi en nombre?", vbYesNo,
"Autorisation")
Mbr = InputBox("Inclure les membres du bureau", "Bureau", "Non")
If Mbr = "Non" Then
Application.EnableEvents = False
[F1] = False
Else
[F1] = True
End If
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")
= 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")
_
= "smtp.orange.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
.Update
End With
'§§§§§§§§§§ D Formation du texte
For i = 5 To [c1000].End(3).Row

strbody = strbody & Cells(i, 3) & vbNewLine
Next
'§§§§§§§§§§ F Formation du texte

Set PlgAdr = Range("A4:" & [B50000].End(3).Address)
PlgAdr.Replace ",", "."
For Each C In Range("B4", Cells(Rows.Count, 2).End(xlUp)) '&
Cells(C.Row, 1)
If C <> "" Then
Prén = Right(Cells(C.Row, 1), Len(Cells(C.Row, 1)) -
InStr(Cells(C.Row, 1), " "))
Nom = Left(Cells(C.Row, 1), InStr(Cells(C.Row, 1), " ") - 1)
If Range("F4:G6020").Find(Prén) Is Nothing Then
Nom = Prén
Prén = Left(Cells(C.Row, 1), InStr(Cells(C.Row, 1), "
") - 1)
End If
If Not (Range("F4:G6020").Find(Prén) Is Nothing) Then
If Range("F4:G6020").Find(Prén).Column = 6 Then
strbody2 = " Madame " & Cells(C.Row, 1) & vbNewLine
& vbNewLine & strbody
ElseIf Range("F4:G6020").Find(Prén).Column = 7 And Prén
<> "" Then
strbody2 = " Monsieur " & Cells(C.Row, 1) &
vbNewLine & vbNewLine & strbody
ElseIf Cells(C.Row, 1) <> "" Then
strbody2 = " Mme, M. " & Cells(C.Row, 1) & vbNewLine
& vbNewLine & strbody
Else
strbody2 = Cells(C.Row, 3) & vbNewLine & vbNewLine &
strbody
End If

End If
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = C.Value
.CC = ""
If [F1] = True And x = 0 Then
.BCC =
"philippe.lebe@wanadoo.fr;elisabeth.haquin08@orange.fr;nathalie.kranyez@capifrance.fr;dometflo08@orange.fr"
Else
.BCC = ""
End If
.From = Exp
Err.Clear
Range("D3:E10").Replace ",", "."
For i = 1 To Application.CountA(Range("D3:D10"))
If Range("D3:D10")(i) <> "" Then
Fichier = Range("E3:E10")(i)

If Right(Range("D3:D10")(i), 1) <> "" And
Right(Range("D3:D10")(i), 1) <> "/" Then
Range("D3:D10")(i) = Range("D3:D10")(i) &
""
End If

FichiersJoints = Range("D3:D10")(i) & Fichier
If Dir(Fichier) = "" Then
' MsgBox "ficher " &
Fichier & " sans adresse"
End If
.AddAttachment FichiersJoints
If InStr(FichierList, Fichier) = 0 Then
FichierList = FichierList & Fichier &
Chr(10)
End If
End If
Next i
If FichierList <> "" Then
FichierList = Left(FichierList, Len(FichierList) -
1)
End If
.Subject = Suj
.TextBody = strbody2
.Send
If Err.Number <> 0 Then
Cells(C.Row, 2).Font.ColorIndex = 9
Err.Clear
Else
Cells(C.Row, 2).Font.Color = 12611584
End If
End With
End If
Next C
End If
Set Flds = Nothing
Set iMsg = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Michd
Le #26465145
Bonjour,
Je ne code pas en HTML, mais il y a un site (probablement plusieurs) qui
édite gratuitement le texte en HTML d'où tu peux ne faire qu'un
copier-coller de ton texte et obtenir le même texte codé selon tes
préférences.
Regarde ici : https://www.quackit.com/html/online-html-editor/full/
à partir de cette adresse, tu définis une variable :
Message = "Le résultat du code obtenir de la page Web"
Dans ton code CDO, tu devras ajouter une ligne ressemblant à :
.HTMLBody = Message
Et à cette adresse, tu as un exemple d'un envoi de courriel utilisant HTML
https://www.rondebruin.nl/win/s1/cdo.htm
MichD
Michd
Le #26465177
Je t'ai déniché un petit exemple :
https://www.cjoint.com/c/HBstb1SN0xi
IL reste beaucoup de travail au niveau du code HTML.
MichD
Fredo P.
Le #26465228
MichDenis, formidable
"Michd" a écrit dans le message de groupe de discussion :
p6cils$3p6$
Je t'ai déniché un petit exemple :
https://www.cjoint.com/c/HBstb1SN0xi
IL reste beaucoup de travail au niveau du code HTML.
MichD
Michd
Le #26465237
Voici un exemple de code qui illustre comment formater un texte (police,
grosseur, couleur de caractère) + insertion d'une variable dans un code HTML
pour envoyer un courriel avec CDO.
Fichier exemple : https://www.cjoint.com/c/HBtoxx6Ltbi
La procédure dans le fichier.
Évidemment vous devez définir les variables selon votre environnement.
'----------------------------------------------------------------
Sub test1()
Dim ObjMail As Object, Fichier As String
Dim ServeurSMTP As String
Dim Suget As String
Dim Destinataire As String, Expediteur As String
Dim FichiersJoints As String, MyVar As String
Dim AutresDestinataires As String, sHTML As String
'***********VARIABLES À DÉFINIR******************
ServeurSMTP = "smtp.maskatel.net" ' ...à définir"
Sujet = "La raison du message"
'MHTMLBody = "Voir plus bas"
'Si plusieurs fichiers : séparer par un point-virgule
Fichier = "c:classeur1.xls" ' si requis
Destinataire = ""
Expediteur = ""
'Si plusieurs adresses : séparer par un point-virgule"
AutresDestinataires = ""
'****************************************
'Émane du site :
'https://www.w3schools.com/tags/tag_font.asp
'Selon tes besoins le contenu de la variable peut provenir
'une cellule ... ce n'est qu'un exemple.
MyVar = "£50"
sHTML = "<HTML>"
sHTML = sHTML & "<HEAD>"
sHTML = sHTML & "<TITLE>Bad News!</TITLE>"
sHTML = sHTML & "</HEAD>"
sHTML = sHTML & "<BODY>"
'police de caractère Arial pour tout le texte du message
'<FONT COLOR=Blue> affecte seulement le text de MyVar couleur bleue
sHTML = sHTML & "<P><FONT FACE=Arial>I owe you <FONT COLOR=Blue>"
'Grosseur de la police de caractère 15 pour la variable MyVar et en GRAS
sHTML = sHTML & "<STRONG><FONT SIZE>" & MyVar & "</STRONG>"
'Retour au texte en noir pour le reste de la phrase
sHTML = sHTML & " sHTML = sHTML & "</BODY></HTML>"
Set ObjMail = CreateObject("CDO.Message")
With ObjMail
.To = Destinataire ' ""
.From = Expediteur
.CC = AutresDestinataires
.Subject = Sujet
.MimeFormatted = True
.HTMLBody = sHTML
.BodyPart.Charset = cdoISO_8859_15
If Dir(Fichier) <> "" Then
.AddAttachment FichiersJoints
End If
With .Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") =
2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
ServeurSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
.Update
End With
.Send
End With
End Sub
'---------------------------------------------------------------
MichD
"Fredo P." a écrit dans le message de groupe de discussion :
p6bjen$98u$
Bonjour,
Peut on formater le texte en gras et/ou couleurs, le message, lors d'un
envoi automatique de courriers avec CDO.Configuration
Routine utilisée:
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object, i%, x%
Dim PlgAdr As Range
Dim strbody As String, strbody2$
Dim C As Range, D As Object
Dim Rep As Byte, Suj$, Exp$, Mbr$, Prén$, Nom$
Dim FichiersJoints As String, Fichier$, FichierList$
On Error Resume Next
Suj = InputBox("Indiquez votre Sujet", "Sujet", [D1])
[D1] = Suj
Exp = InputBox("indiquez l'expéditeur", "Expéditeur", [D2])
Rep = MsgBox("Autorisez vous l'envoi en nombre?", vbYesNo,
"Autorisation")
Mbr = InputBox("Inclure les membres du bureau", "Bureau", "Non")
If Mbr = "Non" Then
Application.EnableEvents = False
[F1] = False
Else
[F1] = True
End If
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")
= 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")
_
= "smtp.orange.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
.Update
End With
'§§§§§§§§§§ D Formation du texte
For i = 5 To [c1000].End(3).Row
strbody = strbody & Cells(i, 3) & vbNewLine
Next
'§§§§§§§§§§ F Formation du texte
Set PlgAdr = Range("A4:" & [B50000].End(3).Address)
PlgAdr.Replace ",", "."
For Each C In Range("B4", Cells(Rows.Count, 2).End(xlUp)) '&
Cells(C.Row, 1)
If C <> "" Then
Prén = Right(Cells(C.Row, 1), Len(Cells(C.Row, 1)) -
InStr(Cells(C.Row, 1), " "))
Nom = Left(Cells(C.Row, 1), InStr(Cells(C.Row, 1), " ") - 1)
If Range("F4:G6020").Find(Prén) Is Nothing Then
Nom = Prén
Prén = Left(Cells(C.Row, 1), InStr(Cells(C.Row, 1), "
") - 1)
End If
If Not (Range("F4:G6020").Find(Prén) Is Nothing) Then
If Range("F4:G6020").Find(Prén).Column = 6 Then
strbody2 = " Madame " & Cells(C.Row, 1) & vbNewLine
& vbNewLine & strbody
ElseIf Range("F4:G6020").Find(Prén).Column = 7 And Prén
<> "" Then
strbody2 = " Monsieur " & Cells(C.Row, 1) &
vbNewLine & vbNewLine & strbody
ElseIf Cells(C.Row, 1) <> "" Then
strbody2 = " Mme, M. " & Cells(C.Row, 1) & vbNewLine
& vbNewLine & strbody
Else
strbody2 = Cells(C.Row, 3) & vbNewLine & vbNewLine &
strbody
End If
End If
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = C.Value
.CC = ""
If [F1] = True And x = 0 Then
.BCC ";;;"
Else
.BCC = ""
End If
.From = Exp
Err.Clear
Range("D3:E10").Replace ",", "."
For i = 1 To Application.CountA(Range("D3:D10"))
If Range("D3:D10")(i) <> "" Then
Fichier = Range("E3:E10")(i)
If Right(Range("D3:D10")(i), 1) <> "" And
Right(Range("D3:D10")(i), 1) <> "/" Then
Range("D3:D10")(i) = Range("D3:D10")(i) &
""
End If
FichiersJoints = Range("D3:D10")(i) & Fichier
If Dir(Fichier) = "" Then
' MsgBox "ficher " &
Fichier & " sans adresse"
End If
.AddAttachment FichiersJoints
If InStr(FichierList, Fichier) = 0 Then
FichierList = FichierList & Fichier &
Chr(10)
End If
End If
Next i
If FichierList <> "" Then
FichierList = Left(FichierList, Len(FichierList) -
1)
End If
.Subject = Suj
.TextBody = strbody2
.Send
If Err.Number <> 0 Then
Cells(C.Row, 2).Font.ColorIndex = 9
Err.Clear
Else
Cells(C.Row, 2).Font.Color = 12611584
End If
End With
End If
Next C
End If
Set Flds = Nothing
Set iMsg = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Publicité
Poster une réponse
Anonyme