Macro to send emails - all files in a specified folder, to one address, but on individual emails

[steallan]

Hi

I'm hoping some macro expert can help with this issue. I've been trying to find a solution to this for quite a while, but with no success. I do think it is possible with vba.

I need a macro that looks in a folder and emails each file in there, individually, to one email address. Seems odd, but that's what we need.

So if the folder has 10 files in it, each one is sent on it's own email, from my logged in outlook email, to one other email address.

All the files are always PDFs.

Can anyone help? Thanks

Stephen

p. s i assume I can have the macro sitting in an excel workbook, but the workbook doesnt actually do anything except house the macro, which in turn accesses Outlook.

 

[healey21]

Hi Stephen,

I have read through your request and have placed the following code and step instructions.

You need to copy each code into Excel VBA in a new Module. In VBA Insert Menu and Select Module. The way I have approached it is to get the file names into a sheet first. You need to replace some stuff here

Sub listFiles1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'use FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Direct it to the folder
Set objFolder = objFSO.GetFolder("File location")
i = 1
'loops through each file
For Each objFile In objFolder.Files
'Add email address
Cells(i, 1) = "enter the email address here"
'Add file name
Cells(i, 2) = objFile.Name
'Add file path
Cells(i, 3) = objFile.path
i = i + 1
Next objFile
End Sub

That is stage one, run the code to see if it pulls in the file names.

Next Add the following code:

Sub Send_Mail(SendTo As String, ToMsg As String, strFile As String)
Dim OutlookApp As Object
Dim OutlookMail As Object

Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

'Send single Email to multiple recipients
With OutlookMail
.To = SendTo
.Subject = "Attachment"
.Body = ToMsg
.Attachments.Add strFile
.Display ' Change to .Send once tested
End With

Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub

This code will be used in the final sub routine. Add the code below:

Sub SendToList()
'change the 10 if more needs to be sent
Dim SendTo As String
Dim ToMsg As String
Dim strFile As String


For i = 1 To 10
SendTo = Cells(i, 1)
If SendTo <> "" Then
ToMsg = Cells(i, 3)
strFile = Cells(i, 3)
Send_Mail SendTo, ToMsg, strFile
End If
Next i
End Sub

You can run this code to generate the emails. Change the number first for the amount of file names it adds into the sheet.

 

[steallan]

Thank you very much, this looks great. I've got meetings all day but I cant wait to get time to try this out.

Best regards

Stephen