Excel Macro to Send Emails with Attachements

[Gaura215]

Dear All

I have a worksheet, which has the following:

1) Coloum A have the name of the files of the attachments;
2) Coloum B have the email addresses;
3) Coloum C have the path where the attachement are saved;

I want a macro which can email all the attachements with the name as in Coloum A to there corresponding email address as mentioned in Coloum B. All attachments are saved in the same folder, path is mentioned in Coloum C.

I want these mails to be displayed and not sent directly.

All excel/macro gurus, please help.

Regards
Gaurav

 

[texasalynn]

try this

Sub Send_Files()
'Working in 2000-2010
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range, FileCell As String, rng As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Sheet3")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("A1:A6")
        If cell.Value Like "?*?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Cells(cell.Row, 2).Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, 7).Value ' change this to what you want as the body message
            folderPath = Cells(cell.Row, 3).Value
                If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
                FileCell = Cells(cell.Row, 1)
                    If Trim(FileCell) <> "" Then
                        If Dir(folderPath & FileCell) <> "" Then
                            fName = folderPath & FileCell
                            .Attachments.Add fName
                        End If
                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

 

[Gaura215]

Thanks Boss for posting reply.

I tested this code. I have to say it work to some extent. Kindly find below my comments on my testing.

1) It is creating mails only for Row 2 & Row 5, absolutely no idea why. For testing puspose I put data only till Row 5, and all of them are in the same format as of Row 2 & 5. but still the code creats mails only for these two rows.
2) It is not attaching anything to the mail. Ideally it should attach the PDF file, path for which is mentioned in coloum C of the corresponding cell. My excel file looks like following:
[TABLE="class: grid, width: 500, align: left"]
<TBODY>[TR]
[TD]RBS 08 A J LEUSSINK
[/TD]
[TD]noud.leussi@gmail.com
[/TD]
[TD]C:\Users\g.khanna\Desktop\RBS Cr. Card\RBS 08 A J LEUSSINK
[/TD]
[/TR]
[TR]
[TD]RBS 08 E.G.H. DE KUIPER
[/TD]
[TD]ernst.de.kuiper@gmail.com
[/TD]
[TD]C:\Users\g.khanna\Desktop\RBS Cr. Card\RBS 08 E.G.H. DE KUIPER
[/TD]
[/TR]
[TR]
[TD]RBS 08 FORREST JORDAN
[/TD]
[TD]forrest.jordan@gmail.com
[/TD]
[TD]C:\Users\g.khanna\Desktop\RBS Cr. Card\RBS 08 FORREST JORDAN
[/TD]
[/TR]
[TR]
[TD]RBS 08 E J GROENLAND
[/TD]
[TD]Eric.groenland@gmail.com
[/TD]
[TD]C:\Users\g.khanna\Desktop\RBS Cr. Card\RBS 08 E J GROENLAND
[/TD]
[/TR]
[TR]
[TD]RBS 08 G.S. LEIJENHORST
[/TD]
[TD]geert.leijenhorst@gmail.com
[/TD]
[TD]C:\Users\g.khanna\Desktop\RBS Cr. Card\RBS 08 G.S. LEIJENHORST
[/TD]
[/TR]
</TBODY>[/TABLE]

















Hope this will give you a view of what my sheets looks like. Please help me out.

 

[texasalynn]

double check your path and file names in explorer to see that they are exactly as you show in your excel file (i.e. check spaces and periods, etc.) On my computer the path might look like
C:\Documents and Settings\ALynn\Desktop

 

[Gaura215]

Its looks like same in my browser as well.

Did you try running this on your system? Did it run fine?

 

[texasalynn]

so your files do not have an extension? (txt, xls, etc)

 

[texasalynn]

so testing with this

Excel 2003
	A	B	C
1	1234.jpg	noud.leussi@gmail.com	C:\Documents and Settings\ALynn\Desktop\Graphic
2	1235.jpg	ernst.de.kuiper@gmail.com	C:\Documents and Settings\ALynn\Desktop\Graphic
3	1236.jpg	forrest.jordan@gmail.com	C:\Documents and Settings\ALynn\Desktop\Graphic
4	1237.jpg	Eric.groenland@gmail.com	C:\Documents and Settings\ALynn\Desktop\Graphic
5	1238.jpg	geert.leijenhorst@gmail.com	C:\Documents and Settings\ALynn\Desktop\Graphic
Sheet2

it worked for me on every line. But if your files do not have an extension then there needs to be a slight modification to the code

 

[Gaura215]

Hello

This works perfectly the way I wanted it to. I have amended the mail body and subject line as per my requirements.

A very little more help required in this code. Actually I need to send these mails from a shared mailbox which is attached to my outlook. So is there an option, that this macro can write that mailbox name in the from field, which is visible in the new mail draft.

I tried adding

.from = "[SH]-NE-NL-creditcards"

but it gives me debug error.