Attach Files Listed in Columns with Email

[K]

Hi all, I have data in Sheet("Emails") as below

D E ----columns
Email to Each Email to all----headings
C:\My Doc\David Terry.xls C:\ImpFile\Report.pdf
C:\My Doc\Suzan Jones.xlsx C:\ImpFile\Analysis.xlsm
C:\My Doc\Jim Carry.doc
C:\My Doc\Brian Ali.xlsm
C:\My Doc\Simon Johnes.gif

I got file paths in column D and E and I need macro on a button which
should create and display emails according to the numbers of file
paths in column D and attach each file (listed in column D) with each
email and then it should attach all the files listed in column E with
all emails. Please note again that macro should attach each file with
each email (listed in column D) and all files with each email (listed
in column E). For example according to above data macro should create
and display five emails as there are five file paths in column D and
attach each file listed in column D with each email and then there are
two file paths in column E so macro should attach both files with all
emails. I also want that macro should extarct the person's name from
the files which are listed in column D and put in "TO" section of
email, so one of the emails should look like, it should have "David
Terry.xls" file attach and it should also have both files attach which
are "Report.pdf" & "Analysis.xlsm" and in "TO" section of email macro
should extract name from file of column D (which will be the
characters before dot) so in this case "David Terry" and put this in
"TO" section of email. I hope i was able to explain my question.
Please can any friend can help.

 

[Ron de Bruin]

Hi K

You can loop through the list and add the files
Here is a example that give you ideas
http://www.rondebruin.nl/mail/folder2/files.htm

 

[K]

Hi Ron, Thanks for replying. Before putting my question to this
group i did go to your website and looked at this example and tried to
change your file attached code to what i need but wasn't very
successful. I was stuck on extracting the names from file name for
"TO" section of email and also wasn't good to put loop code. I am
glad that you replied for my this question. It will be very nice of
you if you can write me a macro and also explain major parts of your
macro for my knowledge and understanding. I am new learner and it
will be great to learn from people like yourself. Please help

 

[Ron de Bruin]

Hi K

I will create a example for you this today or tomorrow

 

[K]

Thanks lot Ron i'll wait for you reply

 

[Ron de Bruin]

Try this (change thye sheet name)

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
Dim Num1 As Long
Dim Num2 As Long

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

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

For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)

If Dir(cell.Value) <> "" Then

Num1 = InStrRev(cell.Value, "\", , 1)
Num2 = InStrRev(cell.Value, ".", , 1)

Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = Mid(cell.Value, Num1 + 1, Num2 - Num1 - 1)
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value

If Dir(cell.Value) <> "" Then
.Attachments.Add cell.Value
End If

If Application.WorksheetFunction.CountA(sh.Columns("E")) > 0 Then
For Each FileCell In sh.Columns("E").SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
End If

.Display 'Or use Send
End With

Set OutMail = Nothing
End If
Next cell

Set OutApp = Nothing

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

[K]

Thanks for your help and time Ron. Your code works superbly

 

[Ron de Bruin]

You are welcome