基于命名范围通过电子邮件发送多个附件

Question

调试以下代码时遇到问题。

我正在尝试自动化宏以根据命名范围发送多个附件。

Sub Test()

 Dim objol As New Outlook.Application, objMail As MailItem
 Dim MyArr As Variant, i As Long

 Set objol = New Outlook.Application
 Set objMail = objol.CreateItem(olMailItem)

 With objMail
 MyArr = Sheets("Sheet1").Range("A2:A9").Value
 .To = ("test@test.com")
 .Subject = "Test"
 .Body = ""
 .NoAging = True
 For i = LBound(MyArr) To UBound(MyArr)
 If Dir(MyArr(i, 1), vbNormal) <> "" Then .Attachments.Add MyArr(i, 1)
 Next i
 .Display
 End With

 End Sub

在我正在测试的示例中，我在范围内只有两个输入（分别在单元格 A2 和 A3 中的“Sheet2”和“Sheet3”）。似乎代码在i=3 处起作用，该行为空白。但我需要这样才能好。由于它所指的列已设置 (A2:A9)，因此用户输入他们想要通过电子邮件在工作簿中找到的工作表的名称。有时用户可以输入 2 个名称或 3 个名称 - 最多为 A9。如果范围中有空白，我只需要代码来结束循环，并发送范围中已经定义的附件。

到目前为止，它一直给我一个类型不匹配的错误？ （类型不匹配发生在If Dir(MyArr(i, 1), vbNormal) <> "" Then .Attachments.Add MyArr(i, 1)

编辑 - 由于Dir 也可能是一个问题 - 范围内的值是工作表名称，因此 Sheet1、Sheet2

Answer 1

这就是你想要的

Sub Mail_ActiveSheet()
    Dim OutApp As Object
    Dim OutMail As Object

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

    Dim Sourcewb As Workbook
    Set Sourcewb = ActiveWorkbook

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

    With OutMail
        .To = "test@test.com"
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .Body = "Body"

        AddAttachments ActiveWorkbook, OutMail

        .Display
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing

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

下面的子程序将从 A2 循环到 A9，然后将调用 SheetExists() 以查看单元格值是否与现有工作表名称匹配。如果是这样，它会将工作表复制到新工作簿中，将其另存为临时文件夹中的文件，将其附加到电子邮件中，然后删除该文件。

Sub AddAttachments(wb As Workbook, mail As Object)
    'Copy sheets
    For i = 2 To 9
        Dim sheetName As String
        sheetName = wb.Sheets("Sheet1").Range("A" & i).Value

        If SheetExists(sheetName, wb) = True Then
            wb.Sheets(sheetName).Copy

            Dim Destwb As Workbook
            Set Destwb = ActiveWorkbook

            Dim FileExtStr As String
            Dim FileFormatNum As Long

            'Determine the Excel version and file extension/format
            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 wb.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

                'Save the new workbook/Mail it/Delete it
                Dim TempFilePath As String
                Dim TempFileName As String

                TempFilePath = Environ$("temp") & "\"
                TempFileName = wb.Name & " " & sheetName & " " & Format(Now, "yymmdd h-mm-ss")

                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                .Close savechanges:=False

                mail.Attachments.Add TempFilePath & TempFileName & FileExtStr

                'Delete the file you have send
                Kill TempFilePath & TempFileName & FileExtStr
            End With
        End If
    Next i
End Sub


 Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

     If wb Is Nothing Then Set wb = ThisWorkbook
     On Error Resume Next
     Set sht = wb.Sheets(shtName)
     On Error GoTo 0
     SheetExists = Not sht Is Nothing
 End Function

这是一个快速的解决方案。请注意，我没有检查错误，即我没有检查文件是否已创建，或者我没有检查同一张工作表是否被多次列出，这可能会给你带来不希望的结果。

额外的努力取决于你