如何在Outlook VBA邮件代码中保留正文并添加HTML签名

我无法在同一段代码中同时添加正文内容与HTML签名，相关代码片段如下：

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
     .to = email
     .cc = copy
     .subject = subject
     .body = body
     .HTMLbody = sig

这里设置的.HTMLbody会覆盖上一行的.body内容。我参考其他示例修改后也没生效，以下是完整项目代码，请求帮忙排查错误：

Sub send_mass_email()
    Dim i As Integer
    Dim name, email, body, subject, copy, place, business As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim fsFile As Object
    Dim fso As Object
Dim fsFolder As Object
Dim strFolder As String
Dim sig As String
sig = ReadSignature("adi.htm")

    HTMLbody = ActiveSheet.TextBoxes("TextBox 1").Text
    
    i = 2
    'Loop down name column starting at row 2 column 1
    Do While Cells(i, 1).Value <> ""
        
        name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
        email = Cells(i, 2).Value
        subject = Cells(i, 3).Value
        copy = Cells(i, 4).Value
        business = Cells(i, 5).Value
       
      answ = MsgBox("what it need to be attach " & Cells(i, 1) & " ?", vbYesNo + vbExclamation, "PSK Check")


If answ <> vbYes Then

      
      
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
             .to = email
             .cc = copy
             .subject = subject
             .HTMLbody = body
             .HTMLbody = sig
                          
             .display
            
    End With
  
 End If
 
 If answ = vbYes Then
 
       Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    If xFileDlg.Show = -1 Then

        
        'replace place holders
        
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
             .to = email
             .cc = copy
             .subject = subject
             
            
             .HTMLbody = body & sig
             
             .display
             
            
        For Each xFileDlgItem In xFileDlg.SelectedItems
                .Attachments.Add xFileDlgItem
            Next xFileDlgItem
            

            
            '.Send
            
        End With
       End If
      
       
        'reset body text
        body = ActiveSheet.TextBoxes("TextBox 1").Text
  End If
  
        i = i + 1
 Loop
    
    Set OutMail = Nothing
    Set OutApp = Nothing
  
    
End Sub

核心错误点 #

• 变量赋值错误：你定义了HTMLbody变量，但实际需要赋值给的是body变量，导致后续body为空，合并签名时没有正文内容。
• HTML内容覆盖问题：在answ <> vbYes的分支里，你先赋值.HTMLbody = body，紧接着又赋值.HTMLbody = sig，后者直接覆盖了前者，自然看不到正文。
• 签名合并的HTML结构问题：直接拼接body & sig可能导致HTML结构混乱，需要确保正文和签名的HTML代码是合法拼接的，比如用<br>分隔或者保持正确的嵌套。
• 重复创建Outlook对象：循环里每次都创建新的OutApp对象，效率低下，应该把Set OutApp = CreateObject("Outlook.Application")放到循环外面。

修复后的完整代码 #

Sub send_mass_email()
    Dim i As Integer
    Dim name, email, body, subject, copy, place, business As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim fsFile As Object
    Dim fso As Object
    Dim fsFolder As Object
    Dim strFolder As String
    Dim sig As String
    Dim xFileDlg As FileDialog
    Dim answ As VbMsgBoxResult
    
    ' 初始化Outlook对象，放在循环外避免重复创建
    Set OutApp = CreateObject("Outlook.Application")
    sig = ReadSignature("adi.htm")
    
    ' 正确赋值给body变量
    body = ActiveSheet.TextBoxes("TextBox 1").Text
    
    i = 2
    ' 遍历收件人行
    Do While Cells(i, 1).Value <> ""
        name = Split(Cells(i, 1).Value, " ")(0) '提取名字
        email = Cells(i, 2).Value
        subject = Cells(i, 3).Value
        copy = Cells(i, 4).Value
        business = Cells(i, 5).Value
       
        answ = MsgBox("是否需要为 " & Cells(i, 1) & " 添加附件？", vbYesNo + vbExclamation, "PSK 检查")

        If answ <> vbYes Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                 .To = email
                 .CC = copy
                 .Subject = subject
                 ' 合并正文与签名，确保HTML结构合法
                 .HTMLBody = body & "<br><br>" & sig
                 .Display
            End With
         End If
         
         If answ = vbYes Then
               Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
            If xFileDlg.Show = -1 Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                     .To = email
                     .CC = copy
                     .Subject = subject
                     ' 合并正文与签名
                     .HTMLBody = body & "<br><br>" & sig
                     .Display
                     
                     ' 添加选中的附件
                     For Each xFileDlgItem In xFileDlg.SelectedItems
                             .Attachments.Add xFileDlgItem
                         Next xFileDlgItem
                     
                     '.Send
                End With
               End If
             
             ' 重置body（如果需要在循环中动态修改可以保留，否则可移除）
             body = ActiveSheet.TextBoxes("TextBox 1").Text
       End If
       
        i = i + 1
     Loop
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set xFileDlg = Nothing
End Sub

额外说明 #

• 如果你从文本框获取的body是纯文本，需要先转换成HTML格式（比如把换行替换成<br>），否则直接拼接会导致格式混乱，示例代码中用<br><br>分隔正文和签名，你可以根据实际需求调整。
• ReadSignature函数需要确保能正确读取到HTML签名文件的内容，否则sig变量为空也会导致签名不显示。

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