Excel VBA to send outlook email - Modify Subject line & Fix attachments

[Miratshah]

Hi Guys,

So I am a complete novice in Excel VBA. I want to send email using Excel VBA.

I have excel sheet in following format
Column A - Name
Column B - To
Column C - Subject
Column D - Path of attachment

Now, each row of this excel should open a new email. I have modified a code to suit me requirements except, I have two issues for which need help.

1. Subject line should be picked up from Column C (similar to Name & To field)

2. Need to fix the range for selecting attachment. As of now, every email has all the attachments from column D. I need only attachment as mentioned in that particular row for each email.

Hope some one can help.

Attaching my code below -

Sub Send_Files()'Working in Excel 2000-2016'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm    Dim OutApp As Object    Dim OutMail As Object    Dim sh As Worksheet    Dim cell As Range    Dim FileCell As Range    Dim rng As Range    Dim strbody As String

    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 path/file names in the E:E column in each row        Set rng = sh.Cells(cell.Row, 1).Range("D1:D1")
        If cell.Value Like "?*@?*.?*" And _           Application.WorksheetFunction.CountA(rng) > 0 Then            Set OutMail = OutApp.CreateItem(0)                        strbody = "This is the body"                                                            With OutMail            Set .SendUsingAccount = OutApp.Session.Accounts.Item(2)            .Display                .to = cell.Value                .Subject = "TestMail"                .HTMLBody = strbody & .HTMLBody                              
                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
                .Display  'Or use .send            End With
            Set OutMail = Nothing        End If            Next cell
    Set OutApp = Nothing    With Application        .EnableEvents = True        .ScreenUpdating = True    End WithEnd Sub

Not sure why the code looks non-formatted.

 

[DanteAmor]

Try this

Sub Send_Files() 'Working in Excel 2000-2016'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  Dim OutApp As Object, OutMail As Object, sh As Worksheet
  Dim cell As Range, FileCell As Range, rng As Range, strbody As String


  'Enter the path/file names in the D:D column in each row
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Set sh = Sheets("Sheet1")
  Set OutApp = CreateObject("Outlook.Application")
  For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
[COLOR=#0000ff]    Set FileCell = Cells(cell.Row, "D")[/COLOR]
    If cell.Value Like "?*@?*.?*" And FileCell.Value <> "" Then
      Set OutMail = OutApp.CreateItem(0)
      strbody = "This is the body"
      With OutMail
        Set .SendUsingAccount = OutApp.Session.Accounts.Item(2)
        .to = cell.Value
[COLOR=#0000ff]        .Subject = Cells(cell.Row, "C").Value[/COLOR]
        .HTMLBody = strbody & .HTMLBody
[COLOR=#0000ff]        If Dir(FileCell.Value) <> "" Then .Attachments.Add FileCell.Value[/COLOR]
        .Display  'Or use .send
      End With
      Set OutMail = Nothing
    End If
  Next cell
  Set OutApp = Nothing
End Sub

 

[Miratshah]

Works wonderful I just made a small change to pick up the non default email signature.

Thank you for your help.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.