Macro génération Email // Problème copie characters spéciaux
Bonjour à tous,
Si je vous sollicite aujpourd'hui c'est du à un problème qui me tracasse depuis quelques jours. J'utilise une macro me permettant de créer un modèle de mail, en prenant comme object un document externe word, ce document continent des chracters spéciaux tel que des symbols de monnaies ($/£) et quand le mail se génère des symbols étoilés apparaissent à la place. Ceci est mon problème principal, cependant ce problème n'existe pas sur VBA 32bits, le probèleme n'existe que quand je passe sur mon ordinatteur 64 bits.
Merci d'avance à tous les lecteurs, toute aide est grandement apprécié, voici le code:
Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim row As Integer
Dim companyName As String
Dim personTitle As String
Dim firstName As String
Dim lastName As String
Dim specialTitle As String
Dim recipientEmail As String
Dim emailSubject As String
Dim emailBody As String
Dim greeting As String
Dim attachmentPath As String
Dim wordApp As Object
Dim wordDoc As Object
Dim tempFilePath As String
' Ligne active
Set ws = ActiveSheet
row = ActiveCell.row ' Get the row of the active cell
' Infos clés
companyName = ws.Cells(row, 1).Value
firstName = ws.Cells(row, 3).Value
recipientEmail = ws.Cells(row, 9).Value
emailSubject = ws.Cells(row, 1).Value & " // " & ws.Cells(3, 3).Value
attachmentPath = ws.Cells(row, 11).Value
' Msg
greeting = "<span style='font-family: Arial; font-size: 10pt; color: #1F3864;'>Dear "
greeting = greeting & firstName & ",</span><br>"
' Ouvrir word read-only
On Error GoTo WordError
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Open(ws.Cells(8, 3).Value, ReadOnly:=True) ' Path from cell C8
' Enregistrement word
tempFilePath = Environ("TEMP") & "\TempEmailBody.html"
wordDoc.SaveAs2 tempFilePath, 8 ' 8 represents wdFormatHTML
wordDoc.Close False
wordApp.Quit
On Error GoTo 0
' Lecture doc
Dim adoStream As Object
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Type = 2 ' Specify stream type - we want to save text/string data.
adoStream.Charset = "utf-8" ' Specify charset for the source text data.
adoStream.Open
adoStream.LoadFromFile tempFilePath
emailBody = adoStream.ReadText
adoStream.Close
Set adoStream = Nothing
Kill tempFilePath
' Outlook creation
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = recipientEmail ' Column I for "Email"
.Subject = emailSubject ' Column K for "Subject"
.HTMLBody = "<html><body>" & greeting & "<br><br>" & emailBody & "</body></html>" ' Combine greeting and email body with HTML formatting
' Attach the file if the attachment path is not empty
If attachmentPath <> "" Then
.Attachments.Add attachmentPath
End If
.Display ' Use .Display to show the email before sending
End With
On Error GoTo 0
' Clean up
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
WordError:
MsgBox "Error word app.", vbCritical
On Error GoTo 0
If Not wordDoc Is Nothing Then wordDoc.Close False
If Not wordApp Is Nothing Then wordApp.Quit
Set wordDoc = Nothing
Set wordApp = Nothing
End SubEDIT Modo : merci d'utiliser les balises de code lorsque vous postez un code et ce via l'icone </> dans la barre de menu. J'ai corrigé votre post
Bonjour Guigui14983,
Le document WORD que tu ouvres avec
est-il au format docx ou doc ?