Envoyer un textRTF par email et garder le formatageRésolu

Question

Bonjour à tous !
J'ai recement développé une application qui envoie des mails SMTP via gmail.
Mon problème est que j'utilise une richTextBox, et que mon application gère le gras, souligné, italique, taille et type de police.
Malheuresement, quand j'envoie le mail, j'obtient un petit charabia, sans la bonne mise en forme.

Comment faire ? voici mon code :

Option Explicit

Dim brouillon As String
Dim police As String
Dim taille As Integer
Dim i As Long



'changer la police
Private Sub CmbPolice_Click()

police = CmbPolice.Text
txtCorps.SelFontName = police


txtCorps.SetFocus
End Sub

'changer la taille
Private Sub CmbTaille_Click()

taille = CmbTaille.Text
txtCorps.SelFontSize = taille

txtCorps.SetFocus
End Sub

'Enregistre le brouillon
Private Sub cmdAfficher_Click()
txtCorps.TextRTF = brouillon
MsgBox "Message sauvegardé récupéré !"

txtCorps.SetFocus

End Sub

Private Sub CmdCarnet_Click()

FrmCarnet.Show

End Sub


'Mettre en gras
Private Sub CmdGras_Click()


If txtCorps.SelBold = False Then
    txtCorps.SelBold = True
    CmdGras.BackColor = ColorConstants.vbWhite
Else
    txtCorps.SelBold = False
    CmdGras.BackColor = &H80000002

End If

txtCorps.SetFocus

End Sub


'mettre en Italique
Private Sub CmdItalique_Click()


If txtCorps.SelItalic = False Then
    txtCorps.SelItalic = True
    CmdItalique.BackColor = ColorConstants.vbWhite
Else
    txtCorps.SelItalic = False
    CmdItalique.BackColor = &H80000002

End If

txtCorps.SetFocus
End Sub

Private Sub CmdSouligne_Click()
'Mettre en gras
If txtCorps.SelUnderline = False Then
    txtCorps.SelUnderline = True
    CmdSouligne.BackColor = ColorConstants.vbWhite
Else
    txtCorps.SelUnderline = False
    CmdSouligne.BackColor = &H80000002

End If

txtCorps.SetFocus
End Sub

Private Sub CmdJoindre_Click()
'FrmExplorateur.Show


End Sub

'bouton de reset
Private Sub CmdReset_Click()

txtLogin.Text = ""
txtA.Text = ""
txtCorps.Text = ""
txtObjet.Text = ""

End Sub

'quitter
Private Sub CmdExit_Click()

End

End Sub

'Sauvegarde du brouillon
Private Sub cmdSauvegarder_Click()

If txtCorps = "" Then
    MsgBox "Il n'y a rien à sauvegarder !"
Else
    brouillon = txtCorps.TextRTF
    MsgBox "Message sauvegardé !"

End If

End Sub



'bouton de test
Private Sub CmdTest_Click()

txtLogin.Text = "blabla@gmail.com"
txtA.Text = "blabla@gmail.com"
txtCorps.Text = "Bonjour, voici un mail de test !"
txtObjet.Text = "Mail de test"

End Sub

'Envoyer le message
Private Sub CmdEnvoyer_Click()

Dim oCDO
 
Set oCDO = CreateObject("CDO.Message")
With oCDO
   With .Configuration.Fields ' Configuration "du compte mail SMTP"
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "465"
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
 
     'Authentification
     .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
     .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = txtLogin
     .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = txtPassword
     '----------------
     .Update
    End With
  .From = txtLogin.Text
  .To = txtA.Text
  '.Cc = CcAddress 'je n'utilise pas cc pour l'instant
  .Subject = txtObjet.Text
  .TextBody = txtCorps.TextRTF
  .AddAttachment ("D:\Logo.jpg")
  MsgBox "Le message a été envoyé !"
  .Send
End With
 
End Sub

Private Sub Form_Load()

'Types de polices

CmbPolice.AddItem "Arial"
CmbPolice.AddItem "Calibri"
CmbPolice.AddItem "Comic Sans MS"
CmbPolice.AddItem "Courier New"



'Taille de la police
    For i = 8 To 15 Step 1
        CmbTaille.AddItem i
    Next i


'bouton gras, italique et souligné
txtCorps.SelBold = False
txtCorps.SelItalic = False
txtCorps.SelUnderline = False




End Sub

cs_blinkme · Accepted Answer

J'ai trouvé !

J'ai utilisé un module pour passer du RTF au html.

J'ai ensuite remplacer cette commande

 .TextBody = txtCorps.TextRTF


par

.HTMLBody = ConvertToHTML(txtCorps)

Utilisateur anonyme · Answer

Bonjour,

L'Alma mater dit que cela prend une passe spéciale pour envoyer du RTF parce que CDO ne supporte pas RTF par défaut.

Là.

TM_ · Answer

Bonjour,

Ou peut on trouver ce module et comment s'appelle t'il ?

Merci

Envoyer un textRTF par email et garder le formatage

3 réponses

Votre réponse

Discussions similaires