Email multiple attachments

[Guest]

I copied this from Ron de Bruin's website. I would like to add several
other columns so I may send one email with multiple attachments. Everyone on
my distribution list will not receive the same files nor the same number of
files. How do I do this?
***********************************
Make a list in Sheet("Sheet1") with
In column A : Names of the people
In column B : E-mail addresses
In column C : Filenames like this C:\Data\Book2.xls (don't have to be Excel
files)

The Macro will loop through each row in Sheet1 and if there is a E-mail
address
and a filename that exist in that row it will create a mail with this
information and send it.


Sub TestFile()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In
Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "*@*" And Dir(cell.Offset(0, 1).Value) <> ""
Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
.Attachments.Add cell.Offset(0, 1).Value
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

Try this

Change Resize(1, 10)
if you want to use more files

Sub TestFileTest()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Dim i As Integer

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells _
.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*@*" Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For i = 1 To cell.Offset(0, 1).Resize(1, 10) _
.SpecialCells(xlCellTypeConstants).Count
If Dir(cell.Offset(0, i).Value) <> "" Then
.Attachments.Add cell.Offset(0, i).Value
End If
Next
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Guest]

Thanks! It worked like a charm.

Try this

Change Resize(1, 10)
if you want to use more files

Sub TestFileTest()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Dim i As Integer

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells _
.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*@*" Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For i = 1 To cell.Offset(0, 1).Resize(1, 10) _
.SpecialCells(xlCellTypeConstants).Count
If Dir(cell.Offset(0, i).Value) <> "" Then
.Attachments.Add cell.Offset(0, i).Value
End If
Next
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub