如何让VBA捕获Excel单元格格式并生成带格式Outlook邮件

现有VBA代码从Excel单元格读取邮件正文并生成Outlook邮件，但无法保留单元格内的字体格式（如粗体、斜体、下划线、字体颜色）。需要修改代码，让用户在Excel单元格中自由设置多处格式后，生成的邮件能完整保留这些格式，同时支持占位符替换。

修改后的完整VBA代码 #

Sub CriarEmails()
    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 AssuntoFormatado As String
    Dim Anexo As Variant
    
    ' 定义邮件模板路径
    Dim ModeloPath As String
    ModeloPath = "C:\Users\rcoquejo\AppData\Roaming\Microsoft\Templates\Modelo.oft" ' 修改为你的模板正确路径
    
    ' 定义包含数据的工作表
    Set ws = ThisWorkbook.Sheets("Clientes")
    Set wsAT = ThisWorkbook.Sheets("Assunto_Texto")
   
    ' 初始化Outlook
    Set OutApp = CreateObject("Outlook.Application")
    
    ' 遍历数据行
    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
        
        ' 将主题中的{NUMERO_CONTA}替换为账号编号
        AssuntoFormatado = Replace(wsAT.Range("B3").Value, "{NUMERO_CONTA}", NumeroConta)
        
        ' 从模板创建新邮件
        Set OutMail = OutApp.CreateItemFromTemplate(ModeloPath)
        
        ' 设置邮件主题
        OutMail.Subject = AssuntoFormatado
        
        ' 将Excel单元格带格式内容转换为HTML，并替换NOME占位符
        CorpoHTML = Replace(ConvertCellToHTML(wsAT.Range("C3")), "NOME", Nome)
        
        ' 设置邮件HTML正文
        With OutMail
            .To = Email
            .BodyFormat = 2 ' HTML格式
            .HTMLBody = CorpoHTML
            
            ' 添加附件
            AnexoArray = Split(Anexos, ";")
            For Each Anexo In AnexoArray
                If Trim(Anexo) <> "" Then
                    .Attachments.Add Trim(Anexo)
                End If
            Next Anexo
            
            ' 显示邮件
            .Display
        End With
        
        ' 释放OutMail对象
        Set OutMail = Nothing
    Next i
    
    ' 释放OutApp对象
    Set OutApp = Nothing
    
End Sub

' 将Excel单元格内容转换为带格式的HTML
Function ConvertCellToHTML(cell As Range) As String
    Dim htmlStr As String
    Dim charCount As Integer
    Dim i As Integer
    Dim currentChar As Characters
    Dim prevBold As Boolean, prevItalic As Boolean, prevUnderline As Boolean
    Dim prevColor As Long
    
    htmlStr = "<html><body>"
    charCount = cell.Characters.Count
    prevBold = False
    prevItalic = False
    prevUnderline = False
    prevColor = cell.Font.Color
    
    For i = 1 To charCount
        Set currentChar = cell.Characters(i, 1)
        
        ' 处理粗体格式
        If currentChar.Font.Bold <> prevBold Then
            If currentChar.Font.Bold Then
                htmlStr = htmlStr & "<b>"
            Else
                htmlStr = htmlStr & "</b>"
            End If
            prevBold = currentChar.Font.Bold
        End If
        
        ' 处理斜体格式
        If currentChar.Font.Italic <> prevItalic Then
            If currentChar.Font.Italic Then
                htmlStr = htmlStr & "<i>"
            Else
                htmlStr = htmlStr & "</i>"
            End If
            prevItalic = currentChar.Font.Italic
        End If
        
        ' 处理下划线格式
        If currentChar.Font.Underline <> prevUnderline Then
            If currentChar.Font.Underline = xlUnderlineStyleSingle Then
                htmlStr = htmlStr & "<u>"
            Else
                htmlStr = htmlStr & "</u>"
            End If
            prevUnderline = (currentChar.Font.Underline = xlUnderlineStyleSingle)
        End If
        
        ' 处理字体颜色
        If currentChar.Font.Color <> prevColor Then
            htmlStr = htmlStr & "</span>" ' 关闭之前的颜色标签
            htmlStr = htmlStr & "<span style='color:#" & Hex(currentChar.Font.Color) & "'>"
            prevColor = currentChar.Font.Color
        End If
        
        ' 处理换行符
        If currentChar.Text = vbCrLf Then
            htmlStr = htmlStr & "<br>"
        ElseIf currentChar.Text = vbLf Then
            htmlStr = htmlStr & "<br>"
        Else
            ' 转义HTML特殊字符
            Select Case currentChar.Text
                Case "&": htmlStr = htmlStr & "&amp;"
                Case "<": htmlStr = htmlStr & "&lt;"
                Case ">": htmlStr = htmlStr & "&gt;"
                Case """": htmlStr = htmlStr & "&quot;"
                Case Else: htmlStr = htmlStr & currentChar.Text
            End Select
        End If
    Next i
    
    ' 关闭所有未闭合的标签
    If prevBold Then htmlStr = htmlStr & "</b>"
    If prevItalic Then htmlStr = htmlStr & "</i>"
    If prevUnderline Then htmlStr = htmlStr & "</u>"
    If prevColor <> cell.Font.Color Then htmlStr = htmlStr & "</span>"
    
    htmlStr = htmlStr & "</body></html>"
    ConvertCellToHTML = htmlStr
End Function

关键改动说明 #

• 格式转换核心逻辑：新增ConvertCellToHTML函数，遍历单元格每个字符的格式属性，将粗体转为<b>、斜体转为<i>、下划线转为<u>、字体颜色转为<span style='color:#XXXXXX'>标签，同时处理换行符为<br>。
• 占位符替换时机调整：先将单元格内容转为HTML，再执行NOME占位符替换，避免格式丢失。
• HTML特殊字符转义：对&、<、>等特殊字符进行转义，确保HTML格式合法。
• 兼容原有功能：保留收件人循环、主题替换、附件添加等原有逻辑，无需修改业务流程。

内容的提问来源于stack exchange，提问作者Rafael Coquejo