VBA批量个性化邮件代码遇运行时错误5：文本框格式无法同步

问题详情 #

• 现有批量个性化邮件发送VBA代码，支持将A1/A4等标记替换为对应单元格的个性化文本
• 需求：将指定文本框（字体为Mary Ann）的字体、字号、段落间距、加粗、下划线格式同步到邮件内容
• 遇到的问题：运行代码时触发运行时错误5；文本内容超过255字符无法从单元格提取，已将文本框替代文本改为“Talent_Review_Briefing”并调整代码，问题仍未解决

原代码 #

Sub Send_Talent_Review_Briefing_email_Test_3()
   
   'Change code to work for my sheet
   
     'Declare variables
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim olApp As Object
    Dim olMail As Object
    Dim i As Long
    Dim lastRow As Long
    Dim emailTo As String
    Dim emailSubject As String
    Dim emailBody As String
    Dim textBox As String
    Dim j As Long
    Dim char As String
    
    'Set workbook and worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Talent_Review_Briefing")
    
    'Set Outlook application
    Set olApp = CreateObject("Outlook.Application")
    
    'Get the text box value
    textBox = ws.Shapes("Talent_Review_Briefing_Email").TextFrame.Characters.Text
    
    'Get the last row with data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    'Loop through the rows
    For i = 2 To lastRow
        'Get the email address, subject and body from the columns
        emailTo = ws.Cells(i, 2).Value
        emailSubject = ws.Cells(i, 3).Value
        emailBody = textBox
        
        'Replace the placeholders with the values from the cells
        emailBody = Replace(emailBody, "A1", ws.Cells(i, 1).Value)
        emailBody = Replace(emailBody, "A4", ws.Cells(i, 4).Value)
        emailBody = Replace(emailBody, "A5", ws.Cells(i, 5).Value)
        emailBody = Replace(emailBody, "A6", ws.Cells(i, 6).Value)
        emailBody = Replace(emailBody, "A7", ws.Cells(i, 7).Value)
        emailBody = Replace(emailBody, "A8", ws.Cells(i, 8).Value)
        emailBody = Replace(emailBody, "A9", ws.Cells(i, 9).Value)
        
        'Create a new email object
        Set olMail = olApp.CreateItem(0)
        
        'Set the email properties
        With olMail
            .To = emailTo
            .subject = emailSubject
            .BodyFormat = 2 'HTML format
            .HTMLBody = "<p>" 'Start a paragraph tag
            
            'Loop through the characters in the email body
            For j = 1 To Len(emailBody)
                'Get the current character
                char = Mid(emailBody, j, 1)
                
                'If the character is a line break, close the paragraph tag and start a new one
                If char = vbNewLine Then
                    .HTMLBody = .HTMLBody & "</p><pstyle='margin:10px;'>"
                Else
                    'Copy the font properties from the text box to the email body
                    'With ws.Shapes("TextBox 1").TextFrame.Characters(j, 1).Font
                    With ws.Shapes("Talent_Review_Briefing_Email").TextFrame.Characters(j, 1).Text
                        .HTMLBody = .HTMLBody & "<span style='font-family:Mary Ann;font-size:12pt;"
                        If .Bold Then .HTMLBody = .HTMLBody & "font-weight:bold;"
                        If .Italic Then .HTMLBody = .HTMLBody & "font-style:italic;"
                        If .Underline Then .HTMLBody = .HTMLBody & "text-decoration:underline;"
                    End With
                End If
            Next j
            
            .HTMLBody = .HTMLBody & "</p>" 'Close the last paragraph tag
            .Display 'Show the email before sending
            '.Send 'Uncomment this line to send the email
        End With
    Next i
    
    'Clean up
    Set olMail = Nothing
    Set olApp = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

问题根源及修复方案 #

核心问题点 #

1. 错误引用字体对象：代码中With ws.Shapes(...).TextFrame.Characters(j,1).Text错误指向文本内容，而非.Font对象，导致无法读取字体样式属性，触发运行时错误5。
2. 长文本提取失效：TextFrame.Characters.Text对超255字符的文本支持不佳，需改用TextFrame2.TextRange.Text获取完整内容。
3. HTML格式错误：段落标签<pstyle='...'>缺少空格，应为<p style='...'>；且原代码循环处理每个字符的逻辑在替换占位符后，文本长度变化会导致原文本框的字体索引与新文本不匹配，样式同步失效。
4. 冗余HTML构建：逐个字符生成<span>会导致HTML代码臃肿，可按文本框中的格式分段提取带样式的HTML，再替换占位符。

修复后的代码 #

Sub Send_Talent_Review_Briefing_email_Fixed()
    'Declare variables
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim olApp As Object
    Dim olMail As Object
    Dim i As Long
    Dim lastRow As Long
    Dim emailTo As String
    Dim emailSubject As String
    Dim textBoxHtml As String
    Dim tempHtml As String
    
    'Set workbook and worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Talent_Review_Briefing")
    
    'Set Outlook application
    Set olApp = CreateObject("Outlook.Application")
    
    '获取文本框的完整HTML格式内容（解决长文本问题）
    textBoxHtml = ws.Shapes("Talent_Review_Briefing_Email").TextFrame2.TextRange.HtmlText
    
    '调整HTML样式：设置段落间距、统一字体（若文本框未全局设置）
    textBoxHtml = Replace(textBoxHtml, "<p>", "<p style='margin:10px 0;'>")
    textBoxHtml = Replace(textBoxHtml, "font-family:", "font-family:Mary Ann,")
    
    'Get the last row with data
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    'Loop through the rows
    For i = 2 To lastRow
        'Get the email address, subject
        emailTo = ws.Cells(i, 2).Value
        emailSubject = ws.Cells(i, 3).Value
        tempHtml = textBoxHtml
        
        'Replace the placeholders with the values from the cells
        tempHtml = Replace(tempHtml, "A1", ws.Cells(i, 1).Value)
        tempHtml = Replace(tempHtml, "A4", ws.Cells(i, 4).Value)
        tempHtml = Replace(tempHtml, "A5", ws.Cells(i, 5).Value)
        tempHtml = Replace(tempHtml, "A6", ws.Cells(i, 6).Value)
        tempHtml = Replace(tempHtml, "A7", ws.Cells(i, 7).Value)
        tempHtml = Replace(tempHtml, "A8", ws.Cells(i, 8).Value)
        tempHtml = Replace(tempHtml, "A9", ws.Cells(i, 9).Value)
        
        'Create a new email object
        Set olMail = olApp.CreateItem(0)
        
        'Set the email properties
        With olMail
            .To = emailTo
            .Subject = emailSubject
            .BodyFormat = 2 'HTML format
            .HTMLBody = tempHtml
            .Display 'Show the email before sending
            '.Send 'Uncomment this line to send the email
        End With
    Next i
    
    'Clean up
    Set olMail = Nothing
    Set olApp = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

修复说明 #

1. 使用TextFrame2.TextRange.HtmlText直接获取文本框的完整HTML格式内容，既解决长文本提取问题，又保留所有字体、段落样式。
2. 直接对HTML文本替换占位符，避免原代码中字符索引不匹配的问题。
3. 修正段落间距的HTML样式，确保邮件显示正确的段落间距。
4. 移除冗余的逐字符循环，大幅提升代码效率和可读性。

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