Excel Macro for attaching multiple files to one email

[comeonyougills]

Good Morning!

I am currently attempting to use an excel macro to allow me to send a list of files to one person. I have managed to create a dynamic list where one sheet of the workbook has the list of files and checkboxes, and as certain ones are selected they appear in a list on the 'front sheet' of my workbook, which has the button to send the email.

My front sheet is set up in a way that in cell B3 I have the desired email address, B4 contains the subject and from B5 to B30 I have the list of selected attachments (although the length of the list obviously varies depending on the amount of files selected, when all are selected the list extends to B30).

I have the below vba code that allows me to create an email with the address and subject and attaches the file address from cell B5, but I would like to attach all the files in the list and am struggling to change the code to do so.

Sub CreateMail()
   
        Dim objOutlook As Object
        Dim objMail As Object
        Dim rngTo As Range
        Dim rngSubject As Range
        Dim rngAttach As Range
               
       
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
       
        With ActiveSheet
            Set rngTo = .Range("B3")
            Set rngSubject = .Range("B4")
            Set rngAttach = .Range("B5")
        End With
       
        With objMail
            .to = rngTo.Value
            .Subject = rngSubject.Value
            .Attachments.Add rngAttach.Value
            .Display
        End With
       
        Set objOutlook = Nothing
        Set objMail = Nothing
        Set rngSubject = Nothing
        Set rngTo = Nothing
        Set rngAttach = Nothing
   
End Sub

I can add more by creating new ranges (rngAttach1, rngAttach2, rngAttach3 etc) and setting these to their respective locations but if, for example, only two files are selected, the list only covers cells B5 and B6, so when the macro looks up the file directory in B7 (rngAttach3) it returns an error because obviously there is nothing for it to find.

I have attempted to compile a loop and change the code to the version shown below but am having no luck.

Sub CreateMail()
    
        Dim objOutlook As Object
        Dim objMail As Object
        Dim rngTo As Range
        Dim rngSubject As Variant
        Dim rngAttach As String
        Dim iLoop As Long
        Dim CellRow As Long
        Dim iLastRow As Long
                       
        
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        
        With ActiveSheet
            Set rngTo = .Range("B3")
            Set rngSubject = .Range("B4")
            CellRow = 5
            iLastRow = Cells(Rows.Count, 1).End(-4162).Row
        End With
        
        With objMail
            .To = rngTo.Value
            .Subject = rngSubject.Value
                 For iLoop = CellRow To iLastRow
                    Set rngAttach = .Range("B,CellRow")
                    .Attachments.Add rngAttach.Value
                 Next iLoop
            .Display
        End With
        
        Set objOutlook = Nothing
        Set objMail = Nothing
        Set rngSubject = Nothing
        Set rngTo = Nothing
        Set rngAttach = Nothing
    
End Sub

Thanks in advance to anyone who can give me a hand with this!

 

[timfritsch]

You could add a function to test if the file exists, and if so then add to the email. The code I've used is:

Function fileExists() As Boolean
  If Len(Dir(filePath & filename)) = 0 Then
    fileExists = False
  Else
    fileExists = True
  End If
End Function

Calling the function:

If fileExists Then
  'code to attach to email
End If

Hope this helps.


Tim

 

[daverunt]

Hi,

a couple of changes work for me.
Your iLastRow returned a 1
rngAttach - ("B, CellRow") is wrong

iLastRow = Cells(Rows.Count, "B").End(-4162).Row

....

Set rngAttach = Range("B" & iLoop)

You can check for empty cell

If Range("B" & iLoop) <> "" Then
                    Set rngAttach = Range("B" & iLoop)
                    .Attachments.Add rngAttach.Value
                    End If

 

[comeonyougills]

Hi Tim,

Thanks so much for your help on this, I think this is definitely the way to go!

I'm a bit of a vba newbie so I'm afraid you'll have to bear with me, but the way I've set up my spreadsheet it puts the file path name in the list of attachments, not the actualy file name (it basically copies a hyperlink of a file when the checkbox returns 'TRUE').

I noticed in your code that you use the Dir Function on filepath&filename, so for me would this just be "rngAttach", which is what I have called the cell B5 where the file path name is pasted?
I have tried to implement your code as shown below, but get the error where 'rngAttach' is a 'Type Mismatch' when used in the function you gave me.

Function fileExists() As Boolean
  If Len(Dir(rngAttach)) = 0 Then
    fileExists = False
  Else
    fileExists = True
  End If
End Function


Sub CreateMail()


        Dim objOutlook As Object
        Dim objMail As Object
        Dim rngTo As Range
        Dim rngSubject As Range
        Dim rngAttach As Range
                                             
       
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
       
        With ActiveSheet
            Set rngTo = .Range("B3")
            Set rngSubject = .Range("B4")
            Set rngAttach = .Range("B5")
        End With
        
              
        With objMail
            .to = rngTo.Value
            .Subject = rngSubject.Value
            If fileExists Then
            .Attachments.Add rngAttach.Value
            End If
            .Display
        End With
       
        Set objOutlook = Nothing
        Set objMail = Nothing
        Set rngSubject = Nothing
        Set rngTo = Nothing
        Set rngAttach = Nothing


End Sub

Once I can get this working I can start to add the other cells in the list.

Thanks, Ash.

 

[comeonyougills]

Dave you hero!

Works beautifully now, thank you so much!

Ash