Texte du mail qui ne s'affiche pas entiérement
M
Bonjour à tous,
Je reviens avec une autre question sur ce code VBA.
Quand j'active la commande, soit une partie de mon corps de mail et manquante juste le "Bonjour" s'affiche, soit j'ai les caractères
%20 et 0D%0A qui s'affiche pouvez-vous me venir en aide ?
Encore un grand merci !
Private Sub CommandButton1_Click()
Dim ProgThunderbird As String
Dim cmd As String
Dim destinataire As String
Dim copie As String
Dim sujet As String
Dim texteBrut As String
Dim texteEncode As String
Dim monCourriel As String
' Chemin vers Thunderbird — adapte si nécessaire
ProgThunderbird = """C:\Program Files\Courrielleur Mel\thunderbird.exe"""
' Adresse mail dans la cellule A1
destinataire = Trim(ThisWorkbook.Sheets(1).Range("A1").Value)
copie = "copie@example.com"
sujet = "Sujet de l'email"
If destinataire = "" Then
MsgBox "La cellule A1 ne contient pas d'adresse email.", vbExclamation
Exit Sub
End If
' Texte du mail avec retours à la ligne vbCrLf
texteBrut = "Bonjour," & vbCrLf & _
"Veuillez trouver ci-joint une attestation de remise de matériel." & vbCrLf & _
"Merci par avance de bien vouloir nous la retourner signé à" & vbCrLf & _
"Merci par avance," & vbCrLf & _
"Bien cordialement."
' Encode le texte en URL UTF-8 (espaces en %20, retours ligne en %0D%0A)
texteEncode = URLEncodeUTF8(texteBrut)
' Construction de la commande -compose
monCourriel = "-compose ""to=" & destinataire & _
",cc=" & copie & _
",subject=" & URLEncodeUTF8(sujet) & _
",body=" & texteEncode & """"
cmd = ProgThunderbird & " " & monCourriel
Debug.Print cmd
' Exécute la commande pour ouvrir Thunderbird avec le mail prêt
Shell cmd, vbNormalFocus
End Sub
Public Function URLEncodeUTF8(ByVal Text As String) As String
Dim i As Long
Dim CharCode As Integer
Dim CharUTF8() As Byte
Dim c As String
Dim Result As String
Result = ""
For i = 1 To Len(Text)
c = Mid(Text, i, 1)
CharCode = AscW(c)
Select Case CharCode
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z
Result = Result & c
Case 32 ' espace
Result = Result & "%20"
Case 13 ' CR
Result = Result & "%0D"
Case 10 ' LF
Result = Result & "%0A"
Case 44, 46, 45, 64 ' , . - @
Result = Result & c
Case Else
CharUTF8 = StrConv(c, vbFromUnicode) ' conversion UTF-8
Dim j As Long
For j = LBound(CharUTF8) To UBound(CharUTF8)
Result = Result & "%" & Right("0" & Hex(CharUTF8(j)), 2)
Next j
End Select
Next i
URLEncodeUTF8 = Result
End FunctionA
Bonjour,
Et comme ceci, ça marche?
Public Function URLEncodeUTF8(ByVal Text As String) As String
Dim i As Long
Dim CharCode As Integer
Dim CharUTF8() As Byte
Dim c As String
Dim Result As String
Result = ""
For i = 1 To Len(Text)
c = Mid(Text, i, 1)
CharCode = AscW(c)
Select Case CharCode
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z
Result = Result & c
Case 32 ' espace
Result = Result & " "
Case 13 ' CR
Result = Result & Chr(10)
Case 10 ' LF
Result = Result & Chr(32)
Case 44, 46, 45, 64 ' , . - @
Result = Result & c
Case Else
CharUTF8 = StrConv(c, vbFromUnicode) ' conversion UTF-8
Dim j As Long
For j = LBound(CharUTF8) To UBound(CharUTF8)
Result = Result & "%" & Right("0" & Hex(CharUTF8(j)), 2)
Next j
End Select
Next i
Range("A1").Value = URLEncodeUTF8
URLEncodeUTF8 = Result
End FunctionCdlt