Excel VBA宏报错：如何将带格式文本框内容插入邮件正文？

问题说明 #

原本用于给客户发送文件的VBA宏，从单元格提取文本时运行正常，但改为从Excel文本框获取带格式内容（高亮、超链接等）后持续报错，无法正常生成带格式的邮件正文。

错误原因分析 #

1. 正文范围获取错误：原代码中Set oRng = wdDoc.TextBoxes错误指向邮件文档的文本框集合，而非邮件正文的内容范围，导致后续collapse和Paste方法调用失败。
2. 对象创建冗余：在循环内重复创建Outlook应用对象，既浪费资源也可能引发交互问题。
3. 变量未声明：多个变量未显式声明，易导致隐式类型错误。

修复后的完整代码 #

Option Explicit

Sub Mail()
    Const wdCollapseStart As Long = 1 '后期绑定需手动定义Word常量
    
    Dim wb As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim xlSheet As Worksheet
    Dim wdDoc As Object
    Dim oRng As Object
    Dim i As Long
    Dim lastRow As Long
    Dim klient As String
    Dim zalacznik1 As String
    Dim zalacznik2 As String
    Dim zalacznik3 As String
    
    '初始化工作簿和工作表对象
    Set wb = Workbooks("BankDetails.xlsm")
    Set ws = wb.Sheets("MessageBody")
    Set ws1 = wb.Sheets("Data")
    Set ws2 = wb.Sheets("Batch")
    Set xlSheet = wb.Sheets("MessageBody") '避免依赖ActiveWorkbook
    
    '仅创建一次Outlook应用
    Set OutApp = CreateObject("Outlook.Application")
    
    lastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        klient = ws2.Cells(i, "A").Value
        
        '拼接附件路径
        zalacznik1 = ws.Cells(4, "B").Value & ws.Cells(5, "B").Value
        zalacznik2 = ws.Cells(4, "B").Value & ws.Cells(6, "B").Value
        zalacznik3 = ws.Cells(4, "B").Value & ws.Cells(7, "B").Value
        
        '创建新邮件
        Set OutMail = OutApp.CreateItem(0)
        
        With OutMail
            .SentOnBehalfOfName = ws.Cells(1, "B").Value
            .BodyFormat = 3 'olFormatHTML
            .BCC = ws2.Cells(i, "B").Value
            .Subject = ws2.Cells(i, "C").Value
            
            '添加附件（先检查文件是否存在）
            If Dir(zalacznik1) <> "" Then .Attachments.Add zalacznik1
            If Dir(zalacznik2) <> "" Then .Attachments.Add zalacznik2
            If Dir(zalacznik3) <> "" Then .Attachments.Add zalacznik3
            
            '获取邮件的Word编辑对象并粘贴带格式内容
            .Display '必须先Display才能获取WordEditor
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Content
            
            '复制文本框内容（每次循环复制确保最新内容）
            xlSheet.TextBoxes("TextBox 1").Copy
            oRng.Collapse Direction:=wdCollapseStart
            oRng.Paste
            
            '可选：直接发送邮件，注释掉.Display改为.Send
            '.Send
        End With
        
        '释放当前邮件相关对象
        Set OutMail = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        
        '标记处理状态
        ws2.Cells(i, "D").Value = "Done, " & Now()
        
        '等待Outlook处理完成
        Application.Wait Now + TimeValue("0:00:02")
    Next i
    
    '释放全局对象
    Set OutApp = Nothing
    Set wb = Nothing
    Set ws = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set xlSheet = Nothing
End Sub

关键修改点 #

• 强制变量声明：添加Option Explicit，避免隐式类型错误。
• 优化Outlook对象创建：将Outlook应用对象的创建移至循环外，减少重复创建的资源消耗。
• 修正正文范围获取逻辑：将Set oRng = wdDoc.TextBoxes改为Set oRng = wdDoc.Content，确保操作的是邮件正文内容而非文本框集合。
• 增加附件有效性检查：通过Dir()函数验证附件路径是否存在，避免因文件缺失报错。
• 调整文本框复制时机：将文本框内容复制操作移至循环内部，保证每次生成邮件时获取最新内容。
• 完善对象释放：明确释放所有对象变量，避免内存泄漏。

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