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

[Forgone]

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.

 

[joel]

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 Su