Excel VBA读取文本框富文本批量发送带格式HTML邮件求助

核心错误排查 #

你当前代码无法运行&格式不生效的原因如下：

• 变量调用错误：GenMail过程中替换占位符时调用了未定义的name变量，实际定义的收件人姓名字段是varTeamname
• 参数传入错误：convert_RTF_to_HTML函数需要接收文本框的Characters集合来逐字符读取格式属性，你传入的是纯文本属性.Text，自然无法读取格式
• CSS语法错误：转换函数里写了重复的font-weight属性名font-weight:font-weight: bold;，导致样式失效
• HTML结构不完整：Outlook的.HTMLBody属性需要完整的HTML基础框架包裹，否则样式无法正常渲染

修正后逐字符转换方案（支持字体、颜色、加粗、下划线） #

Sub GenMail()
    Dim i As Integer
    Dim varTeamname As Variant
    Dim varEmail As Variant
    Dim varBody As Variant
    Dim varSubject As Variant
    Dim strCopy As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim txtBox As Object
    
    ' 绑定文本框对象
    Set txtBox = ActiveSheet.TextBoxes("ZoneTexte 1")
    
    i = 2
    ' 遍历收件人列表
    Do While Cells(i, 1).Value <> ""
        varTeamname = Cells(i, 1)
        varEmail = Cells(i, 2).Value
        varSubject = Cells(i, 3).Value
        strCopy = Cells(i, 4).Value
        
        ' 传入文本框的Characters集合转换HTML
        varBody = convert_RTF_to_HTML(txtBox.Characters)
        ' 替换占位符，注意变量名是varTeamname
        varBody = Replace(varBody, "C1", varTeamname)
        ' 补全HTML基础框架
        varBody = "<html><body>" & varBody & "</body></html>"
        
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
             .To = varEmail
             .CC = strCopy
             .Subject = varSubject
             .HTMLBody = varBody
             .Display
             ' 如需自动发送取消下一行注释
             '.Send
        End With
        
        Set OutMail = Nothing
        Set OutApp = Nothing
        i = i + 1
    Loop
    Set txtBox = Nothing
End Sub


Public Function convert_RTF_to_HTML(ByVal parCharacters As Variant) As String
    Dim sHTML As String
    sHTML = ""
    Dim bChange As Boolean
    
    Dim intColor As Long
    intColor = 0
    Dim intRed As Long, intGreen As Long, intBlue As Long
    
    Dim sFontName As String
    sFontName = ""
    Dim sFontSize As String
    sFontSize = ""
    Dim sUnderline As String
    sUnderline = ""
    
    Dim bBold As Integer
    bBold = 0
    Dim bItalic As Integer
    bItalic = 0
    
    Dim varChar
    For Each varChar In parCharacters
        bChange = False
        
        ' 读取单字符属性
        Dim char_Text As String
        char_Text = varChar.Text
        Dim char_FontName As String
        char_FontName = varChar.Font.Name
        Dim char_FontSize As String
        char_FontSize = varChar.Font.Size
        Dim char_Underline As String
        char_Underline = varChar.Font.UnderlineStyle
        Dim char_RGB As Long
        char_RGB = varChar.Font.Fill.ForeColor.RGB
        Dim char_Bold As Integer
        char_Bold = varChar.Font.Bold
        Dim char_Italic As Integer
        char_Italic = varChar.Font.Italic
        
        ' 判断格式是否变化
        If sFontName <> char_FontName Then bChange = True: sFontName = char_FontName
        If sFontSize <> char_FontSize Then bChange = True: sFontSize = char_FontSize
        If sUnderline <> char_Underline Then bChange = True: sUnderline = char_Underline
        If intColor <> char_RGB Then 
            bChange = True
            intColor = char_RGB
            intRed = intColor And &HFF
            intGreen = (intColor And &HFF00&) \ 256
            intBlue = (intColor And &HFF0000) \ 65536
        End If
        If bBold <> char_Bold Then bChange = True: bBold = char_Bold
        If bItalic <> char_Italic Then bChange = True: bItalic = char_Italic
        
        ' 换行转换
        char_Text = Replace(char_Text, vbCrLf, "<br>")
        char_Text = Replace(char_Text, vbLf, "<br>")
        
        ' 生成样式标签
        If bChange Then
            sHTML = sHTML & "</span>"
            sHTML = sHTML & vbCrLf & "<span style="""
            sHTML = sHTML & "font-family:" & sFontName & ";"
            sHTML = sHTML & "font-size:" & sFontSize & "pt;"
            If sUnderline <> 0 Then sHTML = sHTML & "text-decoration:underline;"
            sHTML = sHTML & "color:rgb(" & intRed & "," & intGreen & "," & intBlue & ");"
            If bBold <> 0 Then sHTML = sHTML & "font-weight:bold;" Else sHTML = sHTML & "font-weight:normal;"
            If bItalic <> 0 Then sHTML = sHTML & "font-style:italic;" Else sHTML = sHTML & "font-style:normal;"
            sHTML = sHTML & """>"
        End If
        sHTML = sHTML & char_Text
    Next
    sHTML = sHTML & "</span>"
    convert_RTF_to_HTML = sHTML
End Function

更稳定的Word中转方案（支持项目符号、对齐等全格式） #

如果需要保留文本框的项目符号、段落对齐等复杂格式，建议调用Word对象将文本框内容直接转HTML，比逐字符处理兼容性更高：

Sub GenMail_WordConvert()
    Dim i As Integer
    Dim varTeamname As String, varEmail As String, varSubject As String, strCopy As String
    Dim OutApp As Object, OutMail As Object
    Dim wordApp As Object, wordDoc As Object
    Dim txtBox As Object
    
    ' 初始化Word对象
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    Set txtBox = ActiveSheet.TextBoxes("ZoneTexte 1")
    
    i = 2
    Do While Cells(i, 1).Value <> ""
        varTeamname = Cells(i, 1)
        varEmail = Cells(i, 2).Value
        varSubject = Cells(i, 3).Value
        strCopy = Cells(i, 4).Value
        
        ' 复制文本框内容到Word中转
        txtBox.Copy
        Set wordDoc = wordApp.Documents.Add
        wordDoc.Content.Paste
        ' 替换占位符
        wordDoc.Content.Find.Execute FindText:="C1", ReplaceWith:=varTeamname, Replace:=2
        ' 导出为HTML
        Dim tempPath As String
        tempPath = Environ("Temp") & "\mail_temp.html"
        wordDoc.SaveAs2 Filename:=tempPath, FileFormat:=10 ' wdFormatHTML
        wordDoc.Close False
        ' 读取HTML内容
        Dim htmlContent As String
        Open tempPath For Input As #1
        htmlContent = Input$(LOF(1), 1)
        Close #1
        Kill tempPath
        
        ' 发送邮件
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
             .To = varEmail
             .CC = strCopy
             .Subject = varSubject
             .HTMLBody = htmlContent
             .Display
             '.Send
        End With
        
        Set OutMail = Nothing
        Set OutApp = Nothing
        i = i + 1
    Loop
    wordApp.Quit
    Set wordDoc = Nothing
    Set wordApp = Nothing
    Set txtBox = Nothing
End Sub

注意：使用Word中转方案需要本机安装Word软件，运行时会临时生成缓存文件，发送完成后会自动删除。

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