如何修改VB代码实现将Excel多个单元格区域作为附件发送到Outlook邮件

代码修改方案 #

你已经完成了核心的变量定义和区域复制逻辑，仅需要补充第二个临时工作簿的存储、附件添加、资源清理步骤即可实现双附件效果，具体调整如下：

• 为两个临时文件设置独立命名，避免存储时互相覆盖
• 补充第二个临时工作簿的保存、附件添加逻辑，保留原有Range("AC6")非空判断避免无效操作
• 补充第二个临时工作簿的关闭、临时文件删除逻辑

修改后完整代码 #

Private Sub CommandButton2_Click()

    Dim Source As Range
    Dim Source2 As Range
    Dim Dest As Workbook
    Dim Dest2 As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName1 As String
    Dim TempFileName2 As String
    Dim FileExtStr As String
    Dim AutoPrint As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    Set Source2 = Nothing
    On Error Resume Next
    Set Source = Range("A1:M47").SpecialCells(xlCellTypeVisible)
    Set Source2 = Range("AB1:AN47").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Set Dest2 = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    
    If Range("AC6") <> "" And Not Source2 Is Nothing Then
        Source2.Copy
        With Dest2.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
            Application.CutCopyMode = False
        End With
    End If

    TempFilePath = Environ$("temp") & "\"
    ' 两个临时文件设置不同命名
    TempFileName1 = "Selection1 of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    TempFileName2 = "Selection2 of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    AutoPrint = Range("Y6").Value

    ' 保存第一个临时文件并添加附件
    With Dest
        .SaveAs TempFilePath & TempFileName1 & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = Range("S6").Value
            .CC = Range("S3").Value
            If Range("T3").Value = "Enter bcc addresses manually here" Then
                .bcc = ""
            Else
                .bcc = Range("T3").Value
            End If
            .Subject = Range("V6").Value
            .Body = Range("U6").Value
            .Attachments.Add Dest.FullName
            ' 新增第二个附件添加逻辑
            If Range("AC6") <> "" And Not Source2 Is Nothing Then
                Dest2.SaveAs TempFilePath & TempFileName2 & FileExtStr, FileFormat:=FileFormatNum
                .Attachments.Add Dest2.FullName
            End If
            If AutoPrint = "Yes" Then
                .Send   'or use .Display
            Else
                .Display
            End If
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
    ' 清理第一个临时文件
    Kill TempFilePath & TempFileName1 & FileExtStr

    ' 新增第二个临时文件的关闭和清理逻辑
    If Range("AC6") <> "" And Not Source2 Is Nothing Then
        Dest2.Close savechanges:=False
        Kill TempFilePath & TempFileName2 & FileExtStr
    End If

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

多附件扩展说明 #

如果后续需要添加更多单元格区域作为附件，只需按照该逻辑新增对应SourceX、DestX变量，完成区域复制后重复「保存临时文件→添加到附件→关闭临时文件→删除临时文件」的步骤即可。附件数量较多时可以用数组+循环简化重复代码。

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