将工作表作为附件发送到工作簿中指定的电子邮件地址列表答案

【问题标题】：Send worksheet as attachment to email address list specified in workbook将工作表作为附件发送到工作簿中指定的电子邮件地址列表
【发布时间】：2021-04-06 11:59:18
【问题描述】：

我正在尝试获取一个子例程，它从一个工作表中获取电子邮件地址列表，然后在同一工作簿中选择另一个工作表并将其附加到电子邮件中。

下面的代码创建了一个新工作簿，其中包含我需要复制然后调试的工作表；

运行时错误“53”：找不到文件

并且没有打开任何 Outlook 电子邮件。

Sub SendAttachment()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sTo As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    
    'set email range
    
    Set emailRng = Workbooks("Paint Ordering List.xlsm").Worksheets("Email_List").Range("A3:A10")

    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next

    sTo = Mid(sTo, 2)

    Sheets("Order_List").Select

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
    
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = sTo
        .CC = ""
        .bcc = ""
        .Subject = "Paint Order List"
        .Body = ""
        .Attachments.Add Destwb.FullName
        .Display
    End With
    On Error GoTo 0
    
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

【问题讨论】：

标签： excel vba email outlook attachment

【解决方案1】：

首先，创建一个对附件的对象引用。

Dim MyAttachments As Object
Set MyAttachments = OutMail.Attachments

其次，您从未真正保存要附加的工作表。因此，首先使用您创建的命名约定保存工作表，然后您的附件需要引用完整路径。不仅仅是工作簿名称。

.Attachments.Add TempFilePath & TempFileName & FileExtStr

【讨论】：