Macro to send email with multiple attachment

[excelcheck123]

hi every one,

I have the below macro which goes into outlook and works very well, however, it has one limitation that I can only attach on file per email. I was wondering if it is possible to add multiple attachments instead of just one attachment per email. every thing else in the code is fine, just to add additional code to add multiple attachments. for example, in the below macro, outlook picks up information from cell a, cell b and cell c in an excel file containing file name, email address of recipient and file path. Now is it possible that multiple file names can be put in cell A to attach to a single email? or any other way to do this. Because I have list of clients to whom i send multiple files to each of them. The below macro only allows me to send one file in one email and i have to send each client multiple emails for each attachment.

please help me in this as this will really solve my problem if the below code can be modified to include multiple attachments.

thanks and best regards,
CJ

Macro:


Sub ReadExcel()
Dim ExcelObject As Object
Dim OutlookApp As Outlook.Application
Dim NewMessage As Outlook.MailItem
Dim OutlookNamespace As Outlook.NameSpace
Dim fName, fLoc, eAddress As String
Dim fNameAddress, fLocAddress, eAddressAddress As String

' Set up the spreadsheet you want to read
On Error Resume Next
Set ExcelObject = GetObject(, "Excel.Application")
If Not Err.Number = 0 Then
MsgBox "You need to have Excel running with the appropriate spreadsheet open first", vbCritical, "Excel Not Running"
End
End If

' Read in the data and create a new message with attachment for each Excel entry
CellRow = 1
Set OutlookApp = Outlook.Application
Do Until ExcelObject.Range(fNameAddress) = ""
fNameAddress = "A" & CellRow
eAddressAddress = "B" & CellRow
fLocAddress = "C" & CellRow
fName = ExcelObject.Range(fNameAddress)
fLoc = ExcelObject.Range(fLocAddress)
eAddress = ExcelObject.Range(eAddressAddress)
fName = fLoc & "\" & fName
Set OutlookApp = Outlook.Application
Set NewMessage = OutlookApp.CreateItem(olMailItem)
Set myAttachments = NewMessage.Attachments
myAttachments.Add fName
With NewMessage
.Recipients.Add eAddress
.Attachments = fName
.Display
' .Subject = "Put your subject here"
' .Send
End With
CellRow = CellRow + 1
fNameAddress = "A" & CellRow
Loop
End Sub

 

[AlphaFrog]

Try this. In column A you can list multiple file names separated by a semicolon example: File1.xls;File2.xls;File3.xls

[COLOR=darkblue]Sub[/COLOR] ReadExcel()


    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] fLoc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range, rng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] vFile [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR], vFiles [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]


    [COLOR=green]'Range of cells with recipeant info[/COLOR]
    [COLOR=green]'Column A is attaachment filenames (multiple filenames separated by ; e.g File1.xls;File2.xls[/COLOR]
    [COLOR=green]'Column B is the email address[/COLOR]
    [COLOR=green]'Column C is the File path for the attachment files[/COLOR]
    [COLOR=darkblue]With[/COLOR] ThisWorkbook.ActiveSheet
        [COLOR=darkblue]Set[/COLOR] rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")
    
    [COLOR=green]' Read in the data and create a new message with attachment for each Excel entry[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rng
    
        [COLOR=green]'File path in column C[/COLOR]
        fLoc = cell.Offset(, 2).Value
        [COLOR=darkblue]If[/COLOR] Right(fLoc, 1) <> "\" [COLOR=darkblue]Then[/COLOR] fLoc = fLoc & "\"
        
        [COLOR=green]'Create a new Email for each recpient[/COLOR]
        [COLOR=darkblue]With[/COLOR] OutApp.CreateItem(0)
            [COLOR=green]'Recipient[/COLOR]
            .Recipients.Add cell.Offset(, 1).Value
            
            [COLOR=green]'Attach each file[/COLOR]
            vFiles = Split(cell.Value, ";")
            [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vFile [COLOR=darkblue]In[/COLOR] vFiles
                [COLOR=darkblue]If[/COLOR] Len(Dir(fLoc & vFile)) [COLOR=darkblue]Then[/COLOR]
                    .Attachments.Add fLoc & vFile
                [COLOR=darkblue]Else[/COLOR]
                    AppActivate ThisWorkbook.Parent
                    MsgBox "Could not locate file: " & vbCr & fLoc & vFile, , "File Not Found"
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]Next[/COLOR] vFile
            
            .Display
            [COLOR=green]' .Subject = "Put your subject here"[/COLOR]
            [COLOR=green]' .Send[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]Next[/COLOR] cell
    
End [COLOR=darkblue]Sub[/COLOR]

 

[blues_oo7]

Hi Sir AlphaFrog happy day to you,
this Macro is very awesome,

Just to ask how can i add CC and BCC email add.

Thanks in Advance.

 

[blues_oo7]

Hi Sir AlphaFrog happy day to you,
this Macro is very awesome,

Just to ask how can i add CC and BCC email add.

Thanks in Advance.

also please include the Subject

Sorry it take 15 mins before i realize i need also the Subject its not always same. thats why i cannot edit my first post.

 

[AlphaFrog]

        [color=green]'Create a new Email for each recpient[/color]
        [color=darkblue]With[/color] OutApp.CreateItem(0)
            [color=green]'To = "Sombody@somewhere.com"[/color]
            .Recipients.Add cell.Offset(, 1).Value
[COLOR=#ff0000]            .CC = "MalindaGates@Microsoft.com"[/COLOR]
[COLOR=#ff0000]            .BCC = "BillGates@Microsoft.com"[/COLOR]
[COLOR=#ff0000]            .Subject = "Your subject here"[/COLOR]
[COLOR=#ff0000]            .Body = "Example text in the body of the email"[/COLOR]
            
            [color=green]'Attach each file[/color]

You may find this site helpful. It has example code for creating and sending email for practically every situation.
Example Code for sending mail from Excel

 

[blues_oo7]

Hi Sir AlphaFrog sorry for late reply, Sir it is possible to do like this with your code

Sir this is what i am asking

'Range of cells with recipient info
'Column A is attachment filenames (multiple filenames separated by ; e.g File1.xls;File2.xls
'Column B is the email address
'Column C is the CC email address
'Column D is the email Subject
'Column E is the email body
'Column F is the File path for the attachment files

by the way your sample macro work like charm, the only thing is i cannot use the direct send (.send)
because i need to add CC address, Subject and email body.





Thank you in advance,

 

[Newport Count]

Hi AlphaFrog,

I've just stumbled across this post - I had a similar problem, which you the above solved! Thanks very much for the above solution.

What I would like to do though is combine this with another function which only allows the email to send if "yes" is in column E (in the above example). I had managed to make this work in another spreadsheet based on this example here: http://www.mrexcel.com/forum/excel-questions/523229-email-macro-every-row-excel-sheet.html - but I just cant combine the two successfully, mainly issues with the For Each...Next function)

Is this possible?

Apologies if I have broken the forum rules by replying to this one, but I thought it would be more appropriate than starting a new thread?



Cheers,
Rich

 

[AlphaFrog]

I have no idea what you want to do with the code from other thread.
I just added a test if column E = Yes, for each row in the loop.

[COLOR=darkblue]Sub[/COLOR] ReadExcel()
    
    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] fLoc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range, rng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] vFile [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR], vFiles [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    
    [COLOR=green]'Range of cells with recipeant info[/COLOR]
    [COLOR=green]'Column A is attaachment filenames (multiple filenames separated by ; e.g File1.xls;File2.xls[/COLOR]
    [COLOR=green]'Column B is the email address[/COLOR]
    [COLOR=green]'Column C is the File path for the attachment files[/COLOR]
    [COLOR=darkblue]With[/COLOR] ThisWorkbook.ActiveSheet
        [COLOR=darkblue]Set[/COLOR] rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")
    
    [COLOR=green]' Read in the data and create a new message with attachment for each Excel entry[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rng
    
        [B][COLOR=green]'Test if column E is Yes[/COLOR]
        [COLOR=darkblue]If[/COLOR] UCase(rng.Offset(, 4).Value) = "YES" [COLOR=darkblue]Then[/COLOR][/B]
    
            [COLOR=green]'File path in column C[/COLOR]
            fLoc = cell.Offset(, 2).Value
            [COLOR=darkblue]If[/COLOR] Right(fLoc, 1) <> "\" [COLOR=darkblue]Then[/COLOR] fLoc = fLoc & "\"
            
            [COLOR=green]'Create a new Email for each recpient[/COLOR]
            [COLOR=darkblue]With[/COLOR] OutApp.CreateItem(0)
                [COLOR=green]'Recipient[/COLOR]
                .Recipients.Add cell.Offset(, 1).Value
                [COLOR=green]'.CC = "MalindaGates@Microsoft.com"[/COLOR]
                [COLOR=green]'.BCC = "BillGates@Microsoft.com"[/COLOR]
                .Subject = "Your subject here"
                .Body = "Example text in the body of the email"
                
                [COLOR=green]'Attach each file[/COLOR]
                vFiles = Split(cell.Value, ";")
                [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vFile [COLOR=darkblue]In[/COLOR] vFiles
                    [COLOR=darkblue]If[/COLOR] Len(Dir(fLoc & vFile)) [COLOR=darkblue]Then[/COLOR]
                        .Attachments.Add fLoc & vFile
                    [COLOR=darkblue]Else[/COLOR]
                        AppActivate ThisWorkbook.Parent
                        MsgBox "Could not locate file: " & vbCr & fLoc & vFile, , "File Not Found"
                    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
                [COLOR=darkblue]Next[/COLOR] vFile
                
                .Display
                [COLOR=green]' .Send[/COLOR]
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        [B][COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR][/B]
        
    [COLOR=darkblue]Next[/COLOR] cell
        
End [COLOR=darkblue]Sub[/COLOR]

 

[Newport Count]

So simple!

thanks a lot!

 

[SunnyFlower123]

I am sending two attachments to each recipient. so in Column A, I put File Name (separate by ; ), Column B is Email Address, Column C is File path and separate by ;

when i running it it getting an error. it says " Run-time error '5': Invalid procedure call or argument", when i click on Debug it highlighted " AppAcitivate ThisWorkbook. Parent

can you please help ? thank you very much.

Try this. In column A you can list multiple file names separated by a semicolon example: File1.xls;File2.xls;File3.xls

[COLOR=darkblue]Sub[/COLOR] ReadExcel()


    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] fLoc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range, rng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] vFile [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR], vFiles [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]


    [COLOR=green]'Range of cells with recipeant info[/COLOR]
    [COLOR=green]'Column A is attaachment filenames (multiple filenames separated by ; e.g File1.xls;File2.xls[/COLOR]
    [COLOR=green]'Column B is the email address[/COLOR]
    [COLOR=green]'Column C is the File path for the attachment files[/COLOR]
    [COLOR=darkblue]With[/COLOR] ThisWorkbook.ActiveSheet
        [COLOR=darkblue]Set[/COLOR] rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")
    
    [COLOR=green]' Read in the data and create a new message with attachment for each Excel entry[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rng
    
        [COLOR=green]'File path in column C[/COLOR]
        fLoc = cell.Offset(, 2).Value
        [COLOR=darkblue]If[/COLOR] Right(fLoc, 1) <> "\" [COLOR=darkblue]Then[/COLOR] fLoc = fLoc & "\"
        
        [COLOR=green]'Create a new Email for each recpient[/COLOR]
        [COLOR=darkblue]With[/COLOR] OutApp.CreateItem(0)
            'To = "Sombody@somewhere.com"            .Recipients.Add cell.Offset(, 1).Value
            .CC = "xxxxx@xxx.com"
            .Subject = "xxxxxxx"
            .Body = "Example text in the body of the email"           
            [COLOR=green]'Attach each file[/COLOR]
            vFiles = Split(cell.Value, ";")
            [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vFile [COLOR=darkblue]In[/COLOR] vFiles
                [COLOR=darkblue]If[/COLOR] Len(Dir(fLoc & vFile)) [COLOR=darkblue]Then[/COLOR]
                    .Attachments.Add fLoc & vFile
                [COLOR=darkblue]Else[/COLOR]
                    [U][B]AppActivate ThisWorkbook.Parent[/B][/U]
                    MsgBox "Could not locate file: " & vbCr & fLoc & vFile, , "File Not Found"
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]Next[/COLOR] vFile
            
            .Display
            [COLOR=green]' .Subject = "Put your subject here"[/COLOR]
            [COLOR=green]' .Send[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]Next[/COLOR] cell
    
End [COLOR=darkblue]Sub[/COLOR]