Excel VBA for Outlook

[ComputerNewbie1992]

Hi All,

I have a spreadsheet which works well but my leadership have asked to expand it's capabilities (If it's possible). Unfortunately I'm useless at VBA coding and had to seek help on the code I'm currently using.

• At the moment I have a text box which is transfered into the email body, but instead I've been asked to include a table within the email instead.
• They've also asked if we can add attachments to the emails which can be changed for each product
  • (I've seen some codes which refer to a local drive, ideally we'd be able to add the attachments to the excel sheet somehow but if this is not possible then I'll have to use the local drive route)

In columns L+M I've tried to show the fields we'd need and tried to explain how I'd ideally like it to show ?‍

I've posted the VBA code I'm using and a Mini sheet of the spreadsheet itself.

Many thanks in advance.

Sub CreateEmails()
 
 Application.ScreenUpdating = False
 
 Dim OutApp As Object, OutMail As Object
 Dim rng As Range, fnd As Range
 Dim x As Long
 Dim Signature As String
 
 Set OutApp = CreateObject("Outlook.Application")
 
 For Each rng In Range("C10", Range("C" & Rows.Count).End(xlUp))
   
     If rng = "x" Then
 
     Set fnd = Range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
         If Not fnd Is Nothing Then
 
         x = fnd.CurrentRegion.Offset(1).Cells.Count - 1
 
         Set OutMail = OutApp.CreateItem(0)
             With OutMail
               .display
               Signature = OutMail.HTMLbody
               .To = Join(Application.WorksheetFunction.Transpose(Range("J" & fnd.Row + 1).Resize(x).Value), ";")
              .cc = "Boss@outlook.co.uk"
               .Subject = Range("C2").Value
               .HTMLbody = "Hi " & rng.Offset(, 3) & "," & "<br><br>" & Range("C4") & "<br>"
               .HTMLbody = .HTMLbody & Signature
               .display
             End With
         End If
     End If
 
 Next rng
 
 Application.ScreenUpdating = True
 End Sub

Example.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2		Email Subject:	New Product
3
4		Email Body:	Please see below details of our latest product:
5
6
7
8		Whole Market?	Full Market
9
10		Company A	x		PoC	David				Company A
11		Company B	x		PoC	Mark				CompanyA1@outlook.com
12		Company C	x		PoC	Steve				CompanyA2@outlook.com		Marketing Material	Attaches to email
13		Company D	x		PoC	Sophie				CompanyA3@outlook.com
14		Company E	x		PoC	Jessia				CompanyA4@outlook.com		Product Name
15		Company F	x		PoC	David				CompanyA5@outlook.com		Product Features
16		Company G	x		PoC	Mark				CompanyA6@outlook.com		Price
17		Company H	x		PoC	Steve						Offer Valid to
18		Company I	x		PoC	Sophie				Company B
19		Company J	x		PoC	Jessia				CompanyB1@outlook.com		How I'd like the email to look:
20		Company K	x		PoC	David				CompanyB2@outlook.com
21		Company L	x		PoC	Mark				CompanyB3@outlook.com		To:	(Company contacts in Column J)
22		Company M	x		PoC	Steve				CompanyB4@outlook.com		Cc:	Boss@outlook.co.uk
23		Company N	x		PoC	Sophie				CompanyB5@outlook.com		Subject:	(Cell C2)
24		Company O	x		PoC	Jessia				CompanyB6@outlook.com		Email Body:
25		Company P	x		PoC	David
26		Company Q	x		PoC	Mark				Company C		Hi [PoC]
27		Company R	x		PoC	Steve				CompanyC1@outlook.com		Please see below details of our latest product:
28		Company S	x		PoC	Sophie				CompanyC2@outlook.com
29		Company T	x		PoC	Jessia				CompanyC3@outlook.com		Product Name
30		Company U	x		PoC	David				CompanyC4@outlook.com		Product Features
31		Company V	x		PoC	Mark				CompanyC5@outlook.com		Price
32		Company W	x		PoC	Steve				CompanyC6@outlook.com		Offer Valid to
33		Company X	x		PoC	Sophie
34		Company Y	x		PoC	Jessia				Company D		[Email Signature]
35		Company Z	x		PoC	David				CompanyD1@outlook.com
Email list

Cell Formulas
Range	Formula
J10	J10	=B10
J18	J18	=B11
J26	J26	=B12
J34	J34	=B13
C10:C35	C10	=IF($C$8="Full Market","x","")

Cells with Data Validation
Cell	Allow	Criteria
C8:E8	List	Full Market, Blank
C10:C35	List	x,

 

[shknbk2]

This will get started on the body portion. We can figure out the attachments later. Is it close so far? You can change the size of the whole table and the individual columns by changing the 300px and 150px numbers to suit your design.

Sub CreateEmails()
    Application.ScreenUpdating = False
    
    Dim OutApp As Object, OutMail As Object
    Dim rng As Range, fnd As Range
    Dim x As Long
    Dim Signature As String
    
    Set OutApp = CreateObject("Outlook.Application")
    For Each rng In Range("C10", Range("C" & Rows.Count).End(xlUp))
        If rng = "x" Then
            Set fnd = Range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                x = fnd.CurrentRegion.Offset(1).Cells.Count - 1
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    Signature = OutMail.HTMLBody
                    .To = Join(Application.WorksheetFunction.Transpose(Range("J" & fnd.Row + 1).Resize(x).Value), ";")
                    .CC = "Boss@outlook.co.uk"
                    .Subject = Range("C2").Value
                    .HTMLBody = "<html><head><style>table, th, td {  border: 1px solid black;border-collapse: collapse;}</style></head><body>"
                    .HTMLBody = .HTMLBody & "Hi " & rng.Offset(, 3) & ",<br><br>"
                    .HTMLBody = .HTMLBody & Range("C4") & "<br><br>"
                    .HTMLBody = .HTMLBody & "<table style=""width:300px"">"
                    .HTMLBody = .HTMLBody & "<tr><td style=""width:150px"">Product Name</td><td style=""width:150px"">" & Range("M14") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Product Features</td><td>" & Range("M15") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Price</td><td>" & Range("M16") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Offer Valid to</td><td>" & Range("M17") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "</table>" '</body></html>"
                    .HTMLBody = .HTMLBody & Signature
                    .Display
                End With
            End If
        End If
    Next rng
    
    Application.ScreenUpdating = True
End Sub

 

[shknbk2]

I'll add that, with spacing, the HTMLBody coding is designed to produce the following. Since whitespace is ignored, the html coding is minimized in the Outlook VBA code above. The Signature copied at the beginning of setting the HTMLBody includes the closing </body></html> tags, so it's merely commented in.

<html>
<head>
<style>
table, th, td {
  border: 1px solid black;
  border-collapse: collapse;}
</style>
</head>
<body>
Hi "rng.Offset(, 3)",<br>
<br>
"Range("C4")"
<br>
<br>
<table style="width:300px">
    <tr>
        <td style="width:150px">Product Name</td>
        <td style="width:150px">"Range("M14")"</td>
    </tr>
    <tr>
        <td>Product Features</td>
        <td>"Range("M15")"</td>
    </tr>
    <tr>
        <td>Price</td>
        <td>"Range("M16")"</td>
    </tr>
    <tr>
        <td>Offer Valid to</td>
        <td>"Range("M17")"</td>
    </tr>
</table>
Signature

Helpful HTML code tags are available lots of places on the web. One example:

W3Schools.com

W3Schools offers free online tutorials, references and exercises in all the major languages of the web. Covering popular subjects like HTML, CSS, JavaScript, Python, SQL, Java, and many, many more.

www.w3schools.com

 

[ComputerNewbie1992]

Thanks @shknbk2. I've copied your code but it's not populating the email so I'm unable to check the email chain. Is this working for you when you try it?

 

[shknbk2]

No. I had tested only the message generation part in Outlook VBA with hard-coded data in place of the Excel range references. When I run the code with your data above now, there is an issue in that Company D only has one recipient. That fails the Transpose part. This code checks to see if there is only one recipient. Other than that, this code generates 4 emails for companies A-D just fine.

Sub CreateEmails()
    Application.ScreenUpdating = False
    
    Dim OutApp As Object, OutMail As Object
    Dim rng As Range, fnd As Range
    Dim x As Long
    Dim Signature As String
    
    Set OutApp = CreateObject("Outlook.Application")
    For Each rng In Range("C10", Range("C" & Rows.Count).End(xlUp))
        If rng = "x" Then
            Set fnd = Range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                x = fnd.CurrentRegion.Offset(1).Cells.Count - 1
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    Signature = OutMail.HTMLBody
                    If x > 1 Then
                        .To = Join(Application.WorksheetFunction.Transpose(Range("J" & fnd.Row + 1).Resize(x).Value), ";")
                    Else
                        .To = Range("J" & fnd.Row + 1).Value
                    End If
                    .CC = "Boss@outlook.co.uk"
                    .Subject = Range("C2").Value
                    .HTMLBody = "<html><head><style>table, th, td {  border: 1px solid black;border-collapse: collapse;}</style></head><body>"
                    .HTMLBody = .HTMLBody & "Hi " & rng.Offset(, 3) & ",<br><br>"
                    .HTMLBody = .HTMLBody & Range("C4") & "<br><br>"
                    .HTMLBody = .HTMLBody & "<table style=""width:300px"">"
                    .HTMLBody = .HTMLBody & "<tr><td style=""width:150px"">Product Name</td><td style=""width:150px"">" & Range("M14") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Product Features</td><td>" & Range("M15") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Price</td><td>" & Range("M16") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "<tr><td>Offer Valid to</td><td>" & Range("M17") & "</td></tr>"
                    .HTMLBody = .HTMLBody & "</table>" '</body></html>"
                    .HTMLBody = .HTMLBody & Signature
                    .Display
                End With
            End If
        End If
    Next rng
    
    Application.ScreenUpdating = True
End Sub

 

[ComputerNewbie1992]

Do I need a particular version of outlook/microsoft excel for your code?

I'm using your code and no emails are populating. Are you able to send me a working excel file so I can look for the differences?

 

[shknbk2]

I can share it a little later (gotta head out). For now, can you go through the code line-by-line in Debug mode and figure out what is going on?

 

[shknbk2]

Here's the file.

Email to companies.xlsm

drive.google.com

 

[ComputerNewbie1992]

Thanks @shknbk2, the code works on your spreadsheet - I'll just use this as my template to save faffing about.

Is it possible to add attachments to the email? Ideally it would be something you can upload to the excel but not sure if this is possible.

 

[shknbk2]

I haven't found any easy way to use VBA to extract an embedded file. A lot of what I've seen writes the embedded file to the disk. It would be easier to handle the attachments from a saved folder. Once the path and files are known, adding attachments is easy. You can put the file locations in cells and get them from the cell values.