Email a range xls files in a folder to recipients listed in worksheet
 

Hi all,

Can someone point me in the right direction?

I have a list of xls files in a folder which I need to email. Each
file has a cover page that has named ranges which has the details of
who I want to send it to and the subject. I'm hoping to find and I
believe the best way to do it is to have a macro that will loop
through each file, open it and send the email automatically.

This is what I have.

Named ranges:
worksheet name = cover
person1, person2, person3, email1, email2, email3, ccdescription

One thing I should note is that person1 will always be used but
person2 & person3 may not be used and be blank.

I've been looking at this link - http://www.rondebruin.nl/mail/folder2/mail1.htm
and based on this, I'm guessing that it would be something like....

Sub loopworkbooks()
For each workbook in folder
Open workbook
Call Sub Mail_workbook_Outlook
Close workbook and do not save
End Sub


Sub Mail_workbook_Outlook_1()
'Working in 2000-2007
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = activeworkbook.sheetname.email1 & ...email2 & ...email3
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub



Any assistance would be sincerely appreciated.

Email a range xls files in a folder to recipients listed in worksheet
 

Try this


Sub loopworkbooks()

Dim BKName As String
Dim DistList As String
Dim BKNames() As String

'create sdistribution list
With ActiveWorkbook.ActiveSheet

'get distribution list from column A
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set DistributionRange = .Range("A1:A" & LastRow)

'make string of email address seperated by semicolon

DistList = ""
For Each cell In DistributionRange
If DistList = "" Then
DistList = cell.Value
Else
'add semicolon between email names
DistList = DistList & ";" & cell.Value
End If
Next cell
End With


Folder = "C:\temp\"


'Create an array of book names
ArrayCount = 0
FName = Dir(Folder & "*.xls")
Do While FName < ""

BKName = Folder & FName
ReDim Preserve BKNames(0 To ArrayCount)
BKNames(ArrayCount) = BKName
ArrayCount = ArrayCount + 1
FName = Dir()
Loop
Call Mail_workbook_Outlook_1(BKNames, DistList)



End Sub


Sub Mail_workbook_Outlook_1(BKNames As Variant, _
DistList As String)

'Working in 2000-2007
'This example send the last saved version of the Activeworkbook

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Dim OutMail As Object

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = DistList
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"

For Each bk In BKNames
.Attachments.Add bk
Next bk
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=148971