Macro to send email with multiple attachment

E

excelcheck123

hi every one,

I have the below codes which works very well, however, i was jus
wondering if it is possible to add multiple attachments instead of jus
one attachment per email. every thing else in the code is fine, just t
add additional code to add multiple attachments. for example, in th
below macro, outlook picks up information from cell a, cell b and cell
in an excel file containing file name, email address of recipient an
file path. Now is it possible that multiple file names can be put i
cell A to attach to a single email? or any other way to do this. Becaus
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 hav
to send each client multiple emails for each attachment.

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

thanks and best regards,
CJ


Code:

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 appropriat
spreadsheet open first", vbCritical, "Excel Not Running"
End
End If

' Read in the data and create a new message with attachment for eac
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 Su
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top