Excel VBA将工作表作为附件发送到工作簿中指定的电子邮件列表

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

当我运行下面的代码时，宏会创建一个新工作簿，其中包含我需要复制并调试的工作表<代码>运行时错误“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

子发送附件（）
Dim OutApp作为对象
将邮件变暗为对象
变光范围为零，cl范围为零
将sTo设置为字符串
Dim FileExtStr作为字符串
Dim FileFormatNum尽可能长
将Sourcewb设置为工作簿
将WB设置为工作簿
Dim TempFilePath作为字符串
将文件名设置为字符串
'设置电子邮件范围
设置emailRng=工作簿（“油漆订购列表.xlsm”）。工作表（“电子邮件列表”）。范围（“A3:A10”）
对于emailRng中的每个cl
sTo=sTo&“；”和cl.值
下一个
sTo=Mid（sTo，2）
工作表（“订单列表”）。选择
设置Sourcewb=ActiveWorkbook
'将活动工作表复制到新工作簿
活动表，收到
设置Destwb=ActiveWorkbook
用Destwb
如果Val（Application.Version）<12，则
“您使用的是Excel 97-2003
FileExtStr=“.xls”：FileFormatNum=-4143
其他的
“您使用的是Excel 2007-2016
选择Case Sourcewb.FileFormat
案例51:FileExtStr=“.xlsx”：FileFormatNum=51
案例52：
如果.hasvb项目
FileExtStr=“.xlsm”：FileFormatNum=52
其他的
FileExtStr=“.xlsx”：FileFormatNum=51
如果结束
案例56:FileExtStr=“.xls”：FileFormatNum=56
其他情况：FileExtStr=“.xlsb”：FileFormatNum=50
结束选择
如果结束
以
TempFilePath=Environ$（“temp”）和“\”
TempFileName=Sourcewb.Name&&Format（现在是“dd-mmm-yy h-mm-ss”）
Set-OutApp=CreateObject（“Outlook.Application”）
Set-OutMail=OutApp.CreateItem（0）
出错时继续下一步
发邮件
.to=sTo
.CC=“”
.bcc=“”
.Subject=“油漆订单列表”
.Body=“”
.Attachments.Add Destwb.FullName
.展示
以
错误转到0
'删除已发送的文件
终止TempFilePath&TempFileName&FileExtStr
发送邮件=无
设置应用程序=无
端接头

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

Dim MyAttachments As Object
Set MyAttachments = OutMail.Attachments

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

.Attachments.Add TempFilePath & TempFileName & FileExtStr