email several attachments (change to ron's macro?)

[as_sass]

Hi!

There's this great macro for emailing several files to people that
found here. The macro and changes that Ron made to it (see below) ar
included at the bottom of this post.

My problem is that I can't get it to work when I change the column
that the various information is in. Additionally, I want to introduce
minor change to make it more efficient. Who can help?

DETAILS:

- Want to change the column that contains emails to "K".
- Want to change range that contains files to L:CW

ADDITIONAL CHANGE:

- Can you manipulate the macro so that only the L:CW range in the FIRS
row contains the file names and paths, and every subsequent row contain
only a single value (e.g., "1") if the file needs to be sent out?

E.G.:

A B ... K ... L ... CW
email C:\test1.txt C:\test2.txt
(e-mail address removed) 1 1
(e-mail address removed) 1

--> John receives files test1.txt and test2.txt, while Bert receive
only file test2.txt



Thanks for your help!

sass





--------------------------------------
ORIGINAL POST:


Ron de Bruin
Guest Posts: n/a

Re: Mail a different files to each person in a range

--------------------------------------------------------------------------------

Hi

I made a small change to avoid that the macro stop when there is on
row without a file name

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

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

On Error GoTo cleanup
For Each cell I
Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA
_
Sheets("Sheet1").Cells(cell.Row, 1).Range("C1:F1")) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

'Enter the file names in the C:F column in each row
'You can make the range bigger if you want, only change the column no
the 1
For Each FileCell In Sheets("Sheet1").Cells(cell.Row, 1).Range("C1:F1"
_
.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Send 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

Hi as_sass

The original macro is here
http://www.rondebruin.nl/mail/folder2/files.htm


Try this tester with the mail addresses in column K and the file names in L1:CW1
The name in column J (you can change that)

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

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

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA( _
Sheets("Sheet1").Cells(cell.Row, 1).Range("L1:CW1")) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For Each FileCell In Sheets("Sheet1").Cells(cell.Row, 1).Range("L1:CW1") _
.SpecialCells(xlCellTypeConstants)
If FileCell.Value = 1 Then
If Dir(Cells(1, FileCell.Column)) <> "" Then
.Attachments.Add Cells(1, FileCell.Column).Value
End If
End If
Next FileCell

.Send 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

Add also the sheet name before cells (2*) in this part of the code
You have problems now if "Sheet1" is not active.

If Dir(Cells(1, FileCell.Column)) <> "" Then
.Attachments.Add Cells(1, FileCell.Column).Value
End If


--
Regards Ron de Bruin
http://www.rondebruin.nl

Hi as_sass

The original macro is here
http://www.rondebruin.nl/mail/folder2/files.htm


Try this tester with the mail addresses in column K and the file names in L1:CW1
The name in column J (you can change that)

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

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

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA( _
Sheets("Sheet1").Cells(cell.Row, 1).Range("L1:CW1")) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

For Each FileCell In Sheets("Sheet1").Cells(cell.Row, 1).Range("L1:CW1") _
.SpecialCells(xlCellTypeConstants)
If FileCell.Value = 1 Then
If Dir(Cells(1, FileCell.Column)) <> "" Then
.Attachments.Add Cells(1, FileCell.Column).Value
End If
End If
Next FileCell

.Send 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[as_sass]

Ron,

You're an Angel.
Thanks.