Mail Merge Email with Attachments (VBA)

[Snaps]

I'm trying to create an email mail merge that will personalize the emails to each individual on my list, at the same time attach a document.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I can currently do everything with a simple mail merge aside from the file attachment. I've read that a VBA macro can accomplish this but my VBA skills are very limited (editing code is semi tough without an example).<o></o>
<o></o>
I have the Word document created for the email with a space for the merge to personalize to the individual based on Column A.<o></o>
<o></o>
Column A - Preferred Name (the name used at the heading of my Word document for personalization)<o></o>
Column B - Email Address<o></o>
Column C - Attachment (the File path to the document)<o></o>
<o></o>
Any help with the VBA coding and the process from where I'm at to successfully sending an attachment with the Word document would be a big help.<o></o>
<o></o>
Also need to add a Subject line to the email so not sure how that works once the VBA is set.<o></o>
<o></o>
Thank you for any help.<o></o>

 

[Snaps]

Wow, I feel pretty foolish now.

The file that was linked from Column D had been moved into a different folder. I guess I figured if the file had been moved it would still execute the email, only the file would be absent.

Thank you

 

[Mayur jain]

we have Ms exel 2007, & in our company we use to share the incentive files with our executives, every employee contribute 30-40 cases in my file, & we can not share there data with other executive, hence we have to send the individual mails with there data. on weekly basis we use to send almost 200 mails to our employees. please advise us some way out to send there files automatically, like excel will automatically filter the data on basis of employee name & send it to concern executive's mail id (which i will mention in sheet 2). please note that we have only MS excel 2007, no other aplication of MS office, in aditon to that we have openoffice complete software too, hence if anything posible in that, please let me know.

 

[Krupali]

After using the code, all attachments get add to evry mail. Like I have 36 entries then 36 attachments get attached on every mail




Here is what I currently have: (Using Excel 2003 and Outlook 2003)
A- Name
B- Email Address
C- Subject Line
D- The Body of the Email
E-Z- Attachments

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 Range, rng As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
 
            strbody = "Dear " & cell.Offset(0, -1).Value & "," & vbNewLine & vbNewLine & _
            GetBoiler(cell.Offset(0, 2))
 
 
            With OutMail
                .To = cell.Value
                .Subject = cell.Offset(0, 1)
                .Body = strbody
 
                For Each FileCell In rng.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
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Again, any help would be very appreciated.
Thank you[/QUOTE]

 

[ABURN]

After using the code, all attachments get add to evry mail. Like I have 36 entries then 36 attachments get attached on every mail




Here is what I currently have: (Using Excel 2003 and Outlook 2003)
A- Name
B- Email Address
C- Subject Line
D- The Body of the Email
E-Z- Attachments

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 Range, rng As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            strbody = "Dear " & cell.Offset(0, -1).Value & "," & vbNewLine & vbNewLine & _
            GetBoiler(cell.Offset(0, 2))


            With OutMail
                .To = cell.Value
                .Subject = cell.Offset(0, 1)
                .Body = strbody

                For Each FileCell In rng.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
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Again, any help would be very appreciated.
Thank you

[/QUOTE]
Hi Krupali - Did you ever get to the bottom of this and what to change in the code to stop it from attaching all files to all emails? I'm currently using the code and have the same problem. If you figured it out, I'd really appreciate the help. Thanks!