Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

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

4 réponses
Avatar
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

4 réponses

Avatar
Michd
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
Avatar
Michd
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
Avatar
Fredo P.
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
Avatar
Michd
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 & "</FONT><FONT COLOR=black> ! do you remember...</P>"
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&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/sendusing&quot;) =
2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/smtpserver&quot;) =
ServeurSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/smtpserverport&quot;)
= 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&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/sendusing&quot;)
= 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/smtpserver&quot;)
_
= "smtp.orange.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport&quot" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://schemas.microsoft.com/cdo/configuration/smtpserverport&quot;)
= 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