如何通过VBA实现发送带指定打开工作表的Excel附件的Outlook邮件

问题场景 #

现有一段可生成邮件并附加Excel工作簿的VBA代码，触发按钮位于工作表1，需求是收件人打开附件时默认显示工作表2，且因存在多个工作表，无法单独发送工作表2。原代码如下：

Sub Rectangle1_Click()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim signature As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    
    With xOutMail
        .display
    End With

    signature = xOutMail.body

    xMailBody = "" & vbNewLine & vbNewLine & _
                "" & vbNewLine & _
                ""
    
    On Error Resume Next
    With xOutMail
        .To = Range("T2")
        .CC = Range("U2")
        .BCC = ""
        .Importance = 2
        .Subject = Range("V2")
        .body = xMailBody & signature
        .Attachments.Add ActiveWorkbook.FullName
        .display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

修改方案 #

核心逻辑是：临时修改工作簿的默认显示工作表为目标工作表，完成邮件附件添加后再恢复原设置，确保原文件不受影响。

修改后的完整代码 #

Sub Rectangle1_Click()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim signature As String
    Dim originalSheet As Worksheet ' 存储原默认工作表
    
    On Error GoTo ErrorHandler ' 启用错误捕获，确保原设置能恢复
    
    ' 记录当前默认显示的工作表
    Set originalSheet = ActiveWorkbook.ActiveSheet
    
    ' 设置默认显示为工作表2（根据实际表名调整，比如Sheets("报表页")）
    Sheets("Sheet2").Activate
    ActiveWorkbook.Save ' 保存设置，确保收件人打开时生效
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    
    With xOutMail
        .display
    End With

    signature = xOutMail.body

    xMailBody = "" & vbNewLine & vbNewLine & _
                "" & vbNewLine & _
                ""
    
    With xOutMail
        .To = Range("T2")
        .CC = Range("U2")
        .BCC = ""
        .Importance = 2
        .Subject = Range("V2")
        .body = xMailBody & signature
        .Attachments.Add ActiveWorkbook.FullName
        .display   'or use .Send
    End With

ErrorHandler:
    ' 恢复原默认工作表并保存
    originalSheet.Activate
    ActiveWorkbook.Save
    
    ' 清理对象
    Set xOutMail = Nothing
    Set xOutApp = Nothing
    On Error GoTo 0
End Sub

关键说明 #

• 新增originalSheet变量记录原默认工作表，避免修改后影响用户本地文件
• 通过Sheets("Sheet2").Activate和ActiveWorkbook.Save设置默认显示工作表，该设置会被保存到工作簿中，收件人打开时会自动显示目标工作表
• 错误处理块ErrorHandler确保无论代码是否出错，都会恢复原默认工作表并保存，避免遗留修改
• 注意：如果工作表2的名称不是Sheet2，请将代码中的Sheets("Sheet2")替换为实际的工作表名称（比如Sheets("月度数据")）

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