我已经编写了一个 VBA 代码来自动创建电子邮件。用户在一个单元格中发送他想要发送的内容。但是，它不捕获字体格式，例如粗体、斜体、下划线或字体颜色。我希望用户能够尽可能自由地在文本中使用多个格式化单词，并使用 VBA 在创建电子邮件时捕获这些单词。
Sub CriarEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim i As Integer
Dim Nome As String
Dim Email As String
Dim Anexos As String
Dim AnexoArray() As String
Dim Assunto As String
Dim NumeroConta As String
Dim CorpoCompleto As String
Dim Corpo As String
Dim Anexo As Variant
Dim CorpoHTML As String
' Defina o caminho do modelo de e-mail
Dim ModeloPath As String
ModeloPath = "C:\Users\rcoquejo\AppData\Roaming\Microsoft\Templates\Modelo.oft" ' Altere para o caminho correto do seu modelo
' Defina a planilha que contém os dados
Set ws = ThisWorkbook.Sheets("Clientes")
Set wsAT = ThisWorkbook.Sheets("Assunto_Texto")
' Obter o texto do corpo do e-mail da célula G2
CorpoCompleto = wsAT.Range("C3").Value
' Obter o assunto do e-mail da célula F2 (opcional)
Assunto = wsAT.Range("B3").Value
' Inicialize o Outlook
Set OutApp = CreateObject("Outlook.Application")
' Loop pelos dados
For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
NumeroConta = ws.Cells(i, 1).Value
Nome = ws.Cells(i, 2).Value
Email = ws.Cells(i, 3).Value
Anexos = ws.Cells(i, 4).Value
' Substituir o marcador pelo número da conta no assunto
AssuntoFormatado = Replace(Assunto, "{NUMERO_CONTA}", NumeroConta)
' Crie um novo e-mail a partir de um modelo
Set OutMail = OutApp.CreateItemFromTemplate(ModeloPath)
' Defina o assunto
OutMail.Subject = AssuntoFormatado
' Corpo do e-mail e Assunto
Corpo = Replace(CorpoCompleto, "NOME", Nome)
' Converter quebras de linha para <br> e garantir a formatação HTML
CorpoHTML = "<html><body>" & Replace(Replace(Corpo, vbCrLf, "<br>"), vbLf, "<br>") & "</body></html>"
' Criar o e-mail com o corpo HTML
With OutMail
.To = Email
.BodyFormat = 2 ' HTML
.HTMLBody = CorpoHTML
' Adicionar anexos
AnexoArray = Split(Anexos, ";")
For Each Anexo In AnexoArray
If Trim(Anexo) <> "" Then
.Attachments.Add Trim(Anexo)
End If
Next Anexo
' Mostrar o e-mail
.Display
End With
' Limpe o objeto OutMail
Set OutMail = Nothing
Next i
' Limpe o objeto OutApp
Set OutApp = Nothing
End Sub
如果您使用的是 Windows，这里有一种方法：
Sub tester()
Debug.Print CellHtml([b2])
End Sub
Function CellHtml(c As Range)
Dim ie As Object, doc As Object
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True
ie.Navigate "about:blank" 'empty page
Application.Wait Now + TimeSerial(0, 0, 2)
Set doc = ie.Document
doc.Open "text/html" 'adding an editable div...
doc.Write "<div id='editor' contenteditable='true' type='text'></div>"
doc.Close
doc.getElementById("editor").Focus 'pasting here
c.Copy 'copy the cell
ie.ExecWB 13, 2 'paste into the div
CellHtml = doc.getElementById("editor").getElementsByTagName("td")(0).innerHTML
ie.Quit
End Function