Emailing Multiple Attachments based on Named Range

Question

Having trouble debugging the code below.

I'm trying to automate a macro to send multiple attachments based on a named range.

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

In the example I'm testing, I just have two inputs in the range ("Sheet2" and "Sheet3" in cells A2 & A3 respectively). It seems like the code acts up at i=3 where the row is blank. But I need that to be okay. As the column it's referring to is set (A2:A9), the user puts in names of worksheets they want to email found in the workbook. Sometimes the user can input 2 names, or 3 names - any amount up to A9. I just need the code to End the looping if there's a blank in the range, and send the attachments already defined in the range.

As of now, it keeps giving me an type mismatch error? (Type mismatch happens at If Dir(MyArr(i, 1), vbNormal) <> "" Then .Attachments.Add MyArr(i, 1)

Edit - could also be an issue due to Dir - the values in the range are the sheet names, so Sheet1, Sheet2

Answer 1

This is what you want

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

The following subroutine will loop from A2 to A9, then will call SheetExists() to see if the cell value matches an existing sheet name. If it does, it copies the sheet into a new workbook, saves it as a file in the temp folder, attaches it to the email and then deletes the file.

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

This is a quick solution. Notice I have not checked for errors i.e. I haven't checked if the file was created or not or I haven't checked if the same sheet is listed more than once which may give you undesirable results.

The extra effort is up to you