Envoyer des courriels d'une maniére automatique

Bonjour , je suis entrain de développer une petite fonction qui me permet d'envoyer des courriels d'une maniére automatique à partir d'un user-form déja crée , ce que j'essayer de faire c'est d'écrire une variable dans une feuille word et après je remplace cette variable par une autre variable qui contienne une chaine de caractères et finalement envoyer le courriel avec un fichier pdf en piéce jointe .

mon probléme c'est que word n'accepte pas plus de 255 caractères , Avez vous des solutions ou des suggestions ?

merci

voici mon code :

Private Sub CommandButton3_Click()
Dim OutApp As Object
Dim OutMail As Object
 Dim i As Integer
 Dim Exp As Byte
 Dim wordDocument As Word.Document
 Dim experience As String
 Dim experience_part As String
 Dim wordApp As Word.Application
 Dim bodymessage(0 To 9) As String
Dim fr(1 To 10) As String
 Set wordApp = CreateObject("word.Application")

     Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup

 For i = 8 To Sheets("SBR").Cells(ActiveSheet.Rows.Count, 1).End(xlUp).row

     If Sheets("SBR").Cells(i, 44) = "OUT" And ActiveSheet.Cells(i, 1) <> "" Then
         wordApp.Documents.Open "txtExcelDatasheet = vaFiles(i)"

         Set wordDocument = wordApp.ActiveDocument

    bodymessage(0) = ""
    bodymessage(1) = ""
    bodymessage(2) = ""

    fr(1) = ""
    fr(2) = ""
    fr(3) = ""

   If Sheets("SBR").Cells(i, 3).Text Like "?*@?*.?*" And _
       LCase(Cells(i, "AR").Value) = "OUT" Then
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
       ' .SentOnBehalfOfName = Sheets("Screening-email results").Range("T14")
        .To = ActiveSheet.Cells(i, 3).Text
        .Subject = " Screening results / "

  .Attachments.Add "C:\Users\xx\Desktop\TEST\" & ActiveSheet.Cells(i, 1).Value & ", " & ActiveSheet.Cells(i, 2).Value & ".pdf", 17

  For Exp = 1 To 10
            Select Case Exp
                Case 1 To 10

                'Abilities/ capacities'

                    If LCase(Cells(i, 23 + Exp).Text) = "DNM" And Sheets("SBR").Cells(4, 23 + Exp) = "Educ" Then
                        bodymessage(Exp - 1) = vbNewLine & " ** " & Sheets("Process Info").Range("B19").Text
                        fr(Exp) = vbNewLine & " ** " & Sheets("Process Info").Range("E19").Text
                    End If

                    If LCase(Cells(i, 23 + Exp).Text) = "DNM" And Sheets("SBR").Cells(4, 23 + Exp) = "EX1" Then
                        bodymessage(Exp - 1) = vbNewLine & " ** " & Sheets("Process Info").Range("B25").Text
                        fr(Exp) = vbNewLine & " ** " & Sheets("Process Info").Range("E25").Text
                    End If

                    If LCase(Cells(i, 23 + Exp).Text) = "DNM" And Sheets("SBR").Cells(4, 23 + Exp) = "EX2" Then
                        bodymessage(Exp - 1) = vbNewLine & " ** " & Sheets("Process Info").Range("B26").Text
                        fr(Exp) = vbNewLine & " ** " & Sheets("Process Info").Range("E26").Text
                    End If
                      If LCase(Cells(i, 23 + Exp).Text) = "DNM" And Sheets("SBR").Cells(4, 23 + Exp) = "EX3" Then
                        bodymessage(Exp - 1) = vbNewLine & " ** " & Sheets("Process Info").Range("B27").Text
                        fr(Exp) = vbNewLine & " ** " & Sheets("Process Info").Range("E27").Text
                    End If

        Next Exp

        experience = bodymessage(0) & bodymessage(1) & bodymessage(2) &  fr(0) _
        & fr(1) & fr(2) 

    If Len(experience) > 200 Then
    Do While Len(experience) >= 200
    experience_part = Left(experience, 200) & "VariableToReplace"
    experience = Right(experience, Len(experience) - 200)
    wordDocument.Content.Find.Execute FindText:="VariableToReplace", ReplaceWith:=experience_part, Replace:=wdReplaceAll
    Loop
    wordDocument.Content.Find.Execute FindText:="VariableToReplace", ReplaceWith:=experience, Replace:=wdReplaceAll

Else
wordDocument.Content.Find.Execute FindText:="VariableToReplace", ReplaceWith:=experience, Replace:=wdReplaceAll
End If

      wordDocument.Content.Find.Execute FindText:="VariableGroupe", ReplaceWith:=ActiveSheet.Cells(i, i + 1).Text, Replace:=wdReplaceAll

        wordDocument.SaveAs "C:\Users\xx\Desktop\TEST" & ActiveSheet.Cells(i, 1).Value & ", " & ActiveSheet.Cells(i, 2).Value & ".pdf", 17

            'set placeholder variable back

        wordDocument.Content.Find.Execute FindText:=experience, ReplaceWith:="VariableToReplace", Replace:=wdReplaceAll

     'End If

 Next i
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True

        Call wordDocument.Close(Word.wdDoNotSaveChanges)
        wordDocument.Save
        wordDocument.Close
        Set wordDocument = Nothing
       Call wordApp.Quit
End Sub