send outlook email with attachment using excel cell reference

[nikhil0311]

Excel 2007
	A	B	C	D	E
1	To	CC	Subject	Mail Body	Attached File path
2	nikhil@gmail.com	nikhil@gmail.com;sam@gmail.com	Top 50 Report	Hi Nik, Plz find attached Report	C:/Nikhil/Top 50/01.Top 50_APAC_2017-10-23.xls
3	Henry@gmail.com;Alexis@gmail.com	Samuel@gmail.com;Robin@yahoo.com	Top 20 Report	Hi Henry, attached is the Top 10 report for your further action	C:/Nikhil/Top 50/01.Top 10_APAC_2017-10-23.xls
Sheet1

Based on the columns A to E values

1 - I need to send emails with attachment/attachments using outlook.

2 - The name of the recipient varies as well as some of the text in the body of the email. However, each of these fields is a cell in the excel worksheet.

can someone please provide me a VBA code.

Excel version - 2010
Outlook version 2010


Thanks in advance!

 

[Macropod]

OK so I have been messing around with Word.
...

Set OutApp = CreateObject("Outlook.Application")

That would be a disaster if Outlook is already running. You also don't want to go pasting Excel cells into Word or Outlook; all that will give you is a table with however many cells you paste there. Rather, you need something like:

Sub SendAsFmtdMsg()
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdRng As Word.Range
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim r As Long, strValue As String, xlWkSht As Excel.Worksheet, xlRng As Excel.Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
  bOL = True
End If
Set xlWkSht = ActiveSheet
For r = 2 To xlWkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row
  With olApp
    Set olMail = wdDoc.MailEnvelope.Item
    With olMail
      .To = xlWkSht.Range("A" & r).Value
      .CC = xlWkSht.Range("B" & r).Value
      .Subject = xlWkSht.Range("C" & r).Value
      .Attachments = xlWkSht.Range("D" & r).Value
      Set olInsp = olMail.GetInspector
      Set wdDoc = olInsp.WordEditor
      Set wdRng = wdDoc.Range(0, 0)
      With wdRng
        .Text = "Dear " & xlWkSht.Range("E" & r).Value & vbCr & "Intro boilerplate text "
        .Collapse wdCollapseEnd
        .Text = xlWkSht.Range("F" & r).Value
        .Font.Bold = True
        .Collapse wdCollapseEnd
        .Font.Reset
        .Text = xlWkSht.Range("G" & r).Value
        .Collapse wdCollapseEnd
        .Text = xlWkSht.Range("H" & r).Value
        .Font.Bold = True
        .Collapse wdCollapseEnd
        .Font.Reset
        .Text = xlWkSht.Range("I" & r).Value & vbCr & "Trailer boilerplate text."
      End With
      .Send
    End With
  End With
Next
ErrExit:
wdApp.Quit: If bOL = True Then olApp.Quit
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Set xlRng = Nothing: Set xlWkSht = Nothing
End Sub

 

[daverunt]

Hi Paul,

Can you explain why it would be a disaster with Outlook running already as I don't understand the issue behind that? (Outlook was running when I tested the macro).

The macro was based on the message being in a single cell, as it was originally, and the user pre-formatting that cell instead of splitting the message across many cells. Either way they'd have message preparation work in Excel.
I expected it to copy across as a single row table, it was just an avenue to explore.
At least it spurred you into providing a nice Word version for the split cell message : )

 

[Macropod]

Can you explain why it would be a disaster with Outlook running already as I don't understand the issue behind that?

Simply because it is liable to start another Outlook instance that tries to use your already-open Outlook files. In my testing, at least, Outlook complains when you try to send an email under that scenario.

 

[daverunt]

Thanks Macropod.


Here's another example that assumes the message to send is quite simplistic i.e only 1 bold expression and 1 bold underlined expression.
It assumes the message is in a single cell - column D.
In column E place the text from that message you wish to be in bold - e.g Top 10.
Column F that which you want bold/underlined - e.g "APAC India"

It takes the text in those columns and adds the required html tags
It then replaces them in the main message.

The macro will look for a comma in the text e.g Hi Nik, and append 2 line breaks after that. no comma, no text.
If the only comma is half way through the message then write the message in column D properly : )

You could go down the route of splitting the message into multiple cells and modify the macro to create the message from that.

Sub HTML_mail()
Dim intro As String
Dim msgStr As String

 Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
  
   For Each cell In rng
    
    rRow = cell.Row
          
    If cell.Value <> "" Then
       EmailSendTo = cell.Value
       EmailCCTo = cell.Offset(0, 1).Value
       EmailSubject = cell.Offset(0, 2).Value
       EmailAtt = cell.Offset(0, 6).Value
       
'Create HTML message from cell
'Get the message
       msgStr = Cells(rRow, 4).Value
                     
'Get the length of the message
       msgStrLen = Len(msgStr)

'Return character number to first comma - add 2 line breaks. If no comma no breaks.
       introLen = InStr(msgStr, ",")
 If Not introLen = 0 Then
       intro = Left(msgStr, introLen) & "<br><br>"
       
 Else
       intro = Left(msgStr, introLen)
 End If
'Get the rest of the message
       msgTxt = Right(msgStr, msgStrLen - introLen)
       
       
'Bold the text in column E and Bold underline the text in Column F

       boldCell = "<b>" & Cells(rRow, 5).Value & "</b>"
       boldULCell = "<b><u>" & Cells(rRow, 6).Value & "</u></b>"
            
' Replace E and F in the text - expects correct case as per what's in the message
       msgMain = Replace(msgTxt, Cells(rRow, 5).Value, boldCell)
       msgMain = Replace(msgMain, Cells(rRow, 6).Value, boldULCell)

 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = EmailSubject
            .To = EmailSendTo
            .CC = EmailCCTo
            .HTMLBody = intro & msgMain
            .Attachments.Add EmailAtt
            .Display
            '.Send
        End With
               
        Set OutMail = Nothing
        Set OutApp = Nothing
        
    End If
    Next
End Sub