创建电子邮件时在 Excel 单元格中使用格式化文本

问题描述 投票：0回答：2

我已经完成了自动创建电子邮件的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
vba email outlook fonts bold
2个回答
0
投票
Sub CriarEmailsComFormatacao()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim wsAT 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 CorpoHTML As String
    Dim Anexo As Variant
    Dim WordApp As Object
    Dim WordDoc As Object
    
    ' 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 assunto do e-mail da célula B3
    Assunto = wsAT.Range("B3").Value
    
    ' Inicialize o Outlook
    Set OutApp = CreateObject("Outlook.Application")
    
    ' Inicialize o Word para capturar a formatação da célula
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    
    ' Loop pelos dados da planilha "Clientes"
    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)
        
        ' Copiar o conteúdo da célula (formatação incluída) para o Word
        wsAT.Range("C3").Copy
        
        ' Criar um novo documento no Word
        Set WordDoc = WordApp.Documents.Add
        WordDoc.Content.Paste ' Colar o conteúdo com formatação
        
        ' Obter o conteúdo do Word como HTML
        CorpoHTML = WordDoc.Content.XML ' Extrai o HTML do Word
        
        ' Substituir o marcador "NOME" no corpo do e-mail
        CorpoHTML = Replace(CorpoHTML, "NOME", Nome)
        
        ' Criar o e-mail com o corpo formatado em HTML
        Set OutMail = OutApp.CreateItemFromTemplate(ModeloPath)
        
        With OutMail
            .To = Email
            .Subject = AssuntoFormatado
            .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
        
        ' Fechar o documento do Word sem salvar
        WordDoc.Close False
        Set WordDoc = Nothing
        Set OutMail = Nothing
    Next i
    
    ' Limpar os objetos
    WordApp.Quit
    Set WordApp = Nothing
    Set OutApp = Nothing
End Sub
0
投票

如果您使用的是 Windows，这里有一种方法：

Sub tester()
    Debug.Print CellHtml([b2])

    'how you might use this in your existing code
    Dim Anexos As String
    Anexos = CellHtml(ws.Cells(i, 4))
    'etc
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
    Do While ie.Busy And Timer - t < 2 'wait till loaded
        DoEvents
    Loop
    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

源单元格：

enter image description here

输出 HTML：

<font face="Arial">this <font size="6">is</font> a
<strong> test</strong> of<font color="#ff0000"> formatting</font> 
<u>some</u> <em>te<font size="7">x</font>t</em></font>

输出浏览器中显示的 HTML：
enter image description here

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.