Excel VBA Embed Individual Images to List of Email Contacts - vba

I have been assigned to send out Christmas greetings that have been customized to specific customers. However, these greetings are in the 100's and doing it automatically would save me hours - and these greetings are done every year!
In Excel, the customer names are listed in column A, the individual emails in column B, and the path to the individual customized greeting file in column C.
What I have currently found is a VBA code that offers me the option to attach (but not embed) these files through their paths to the individual emails.
Might anyone explain to me and/or demonstrate how to embed the attached files that are found through column C ?
Thank you very much!
What I have now is the following:
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
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 C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Merry Christmas!"
.Body = "Merry Christmas!"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value, olByValue, 0
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

You could do using HTML email, something like
Set o = Application.CreateItem(olMailItem)
o.BodyFormat = olFormatHTML
o.HTMLBody = "<img src='C:\Users\Pictures\a1.png'>"
o.Display

Related

Excel Add-In/Macro to send mass email

So I have a task to automate. We have a protected spreadsheet (users only have 'read' access to) that get's updated by admins from time to time in order to add/remove users from a paid subscription mailing list. I'm trying to make the process of sending these emails out simpler to speed up the process and eliminate the potential of human error getting involved.
So email addresses are listed under the 'C' column, lists can be as long as in the tens of thousands, or it may only be 1 or 2. The workbook has several sheets that specify the data set that the subscribers subscribe to. So I put something together that worked
'This function will grab the information the macro asks for
Function RangeToString(ByVal myRange As Range) As String
RangeToString = ""
If Not myRange Is Nothing Then
Dim myCell As Range
For Each myCell In myRange
RangeToString = RangeToString & "; " & myCell.Value
Next myCell
'Remove extra comma
RangeToString = Right(RangeToString, Len(RangeToString) - 1)
End If
End Function
Sub EmailTest1()
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String
Dim myString As String
Dim rng As Range
Dim strCopy As String
'Sheet1 would be Sheet2/3/4/etc. depending on what list we're pulling from.
Set rng = Sheet1.Range("c2:c90000")
myString = RangeToString(rng)
strCopy = "internal.private#email.com; internal1.private#email.co;
internal2.private#email.co"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\Domain\EmailTemplate\oft\test1.oft")
On Error Resume Next
With OutMail
.BCC = myString + strCopy
.Display
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Then I had repeats of the second part that specify the different lists/email templates as individual macros within the Add-In. (.Send will not be commented out when I do finally get the results I want).
So this works perfectly, when the macro specifies and embeds a workbook into itself. So for a while, I thought that it was pulling everything fine, until I used a blank workbook, and it still pulled the data I wanted, so I checked and double checked that there was no reference to the original workbook, and then I discovered that the workbook was built into the macro. I tried rebuilding the add-in using the same code, and it just doesn't work.
So my question is, is there a way to build this macro so that it'll work on any active workbook? I imagine there has got to be a simple thing to click on or something else I'm overlooking. I'm working with Excel 2016.
first of all, why didn't you just make a macro-embedded template where you have a form that connects any active workbook.
dim ws as workbook
set ws=activeworkbook
so basically make a form that is modular then on a label click event put that code.
then an execute button so that you can determine if you connect the right workbook before you start the email sending automation
I think you can adapt this to suit your needs.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
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
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 C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Excel-outlook VBA 2013 not working on 2016 Outlook version

I'm having problems with a macro. It used to work on the 2013 version of outlook and excel but for some reason the CC function has stopped working and I keep getting errors.
With the 2013 version I used the following code to define the CC and BCC:
Set sh = Sheets ("Sheet1")
.to = cell.Value
.CC = sh.Cells(cell.Row, 1).Range("C1:C1")
.BCC = sh.Cells(cell.Row, 1).Range("D1:D1")
This however doesn't work in the 2016 version of my excel and outlook. Every single row in excel need to have its own To , CC and BCC selected from a row in Excel. For some reason it keeps saying CC is not a valid method. object_Mailitem failed.
Editing the variables behind the .cc and .bcc to "mail#x.com" is working without getting the error. So I assume there is something wrong with the line after the .cc, i've tried multiple solutions which ended up in either the same error or an other error telling me it doesn't recognize the .Send command.
EDIT: added the full code of the macro
Sub Send files()
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 ccontvangen 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)
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)
With OutMail
.to = cell.Value
.cc = "x"
.Subject = "Subject"
.Attachments.Add "G:\signature.png", olByValue, 0
.Body = " "
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
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I had encountered a similar issue where the Subject Line, To, and Cc were not being listed completely.
I figured out the problem by adding a & ";" to the end of each field.

Automatically send an email if a specific cell value exists; include adjacent value in body

I have been working on an xlsm sheet that as part of its function produces a result of "No Data" in column J if it cannot find a match in its other data files.
What I need is to have Excel loop through Column J and automatically generate an email if the value in J = "No Data" and in the body of the email I need to include the cell offset value from Column F of the same Row.
I have used the Ron De Bruin code and modified it with Looping code from a similar function elsewhere in the project.
I cannot get this to function and could use some direction. Here is the code I have up to this point
Private Sub EmailIC()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'This macro adapted from: http://www.rondebruin.nl/win/s1/outlook/bmail4.htm
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim wbXLoc As String, wbX As Workbook, wsX As Worksheet, wsXName As String
Dim Xlr As Long
Dim rngX As Range, cel As Range, order As Range
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
wbXLoc = "C:\Users\Cole\Downloads\Dads Work\XDock\AutoXrpt.xlsm"
wsXName = "AutoX"
Set wsX = wbX.Sheets(wsXName)
'Loop through Column J to determine if = "No Data"
With wbX
Xlr = .Sheets("AutoX").Cells(Rows.Count, 1).End(xlUp).Row
Set rngX = wbX.Sheets("AutoX").Range("J2:J" & Xlr)
End With
'do the loop and find
For Each cel In rngX
If cel.Value = "No Data" Then
On Error Resume Next
With OutMail
.to = "robe******#msn.com"
.CC = ""
.BCC = ""
.Subject = "Need Pick Face please!"
.Body = rngX.cel.Offset(0, -4).Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cel
End Sub
What Om3r has looks good, they pointed out that you needed to set the wsX variable to an actual sheet before being able to set the range variable rngX. This might be why your loop might not have worked. Hard to say without knowing what error was thrown when you ran your code.
Also, be sure to have the object library for Outlook enabled. Check under the ribbon Tools>References and make sure your Outlook Library is listed.
you may want to try this (commented) code:
Option Explicit
Private Sub EmailIC()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'This macro adapted from: http://www.rondebruin.nl/win/s1/outlook/bmail4.htm
Dim OutApp As Outlook.Application
Dim wbXLoc As String, wsXName As String
Dim cel As Range, order As Range
Set OutApp = CreateObject("Outlook.Application")
wbXLoc = "C:\Users\Cole\Downloads\Dads Work\XDock\AutoXrpt.xlsm"
wsXName = "AutoX"
With Workbooks.Open(wbXLoc).Worksheets(wsXName) '<-- open 'wbXLoc' workbook and reference its 'wsXName' worksheet
With .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)) '<--| reference its column "J" cells from row 1 down to its last non empty cell
.AutoFilter field:=1, Criteria1:="No Data" '<--| filter referenced cells with "No Data" criteria
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell ha been filtered othre than the header (in row 1)
For Each cel In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeVisible) '<-- loop through filtered cells (skippin header in row 1)
With OutApp.CreateItem(olMailItem) '<-- cerate and reference a new mail item
.to = "robe******#msn.com"
.CC = ""
.BCC = ""
.Subject = "Need Pick Face please!"
.Body = cel.Offset(0, -4).Value
.Send
End With
Next cel
End If
End With
End With
ActiveWorkbook.Close False '<--| close opened workbook discarding changes (i.e. autofiltering)
OutApp.Quit '<-- quit Outlook
Set OutApp = Nothing
End Sub
little confused to what you doing, but this should get you started-
Option Explicit
Private Sub EmailIC()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'This macro adapted from: http://www.rondebruin.nl/win/s1/outlook/bmail4.htm
Dim OutApp As Object ' Outlook.Application
Dim OutMail As Outlook.MailItem
' Dim wbXLoc As String
' Dim wbX As Workbook
Dim wsX As Worksheet
' Dim wsXName As String
' Dim Xlr As Long
Dim rngX As Range
Dim cel As Range
' Dim order As Range
Set OutApp = CreateObject("Outlook.Application")
' wbXLoc = "C:\Users\0m3r\Desktop\Macro-VBA\0m3r.xlsm"
' wsXName = "Sheet2"
Set wsX = ThisWorkbook.Worksheets("AutoX")
' wsXName = "AutoX"
' Set wsX = wbX.Sheets(wsXName)
'Loop through Column J to determine if = "No Data"
' With wbX
' Xlr = .Sheets("AutoX").Cells(Rows.Count, 1).End(xlUp).Row
' Set rngX = wbX.Sheets("AutoX").Range("J2:J" & Xlr)
' End With
Set rngX = wsX.Range("J2", Range("J65536").End(xlUp))
'do the loop and find
For Each cel In rngX
If cel.Value = "No Data" Then
Set OutMail = OutApp.CreateItem(olMailItem)
Debug.Print cel.Value
Debug.Print cel.Offset(0, -4).Value
' On Error Resume Next
With OutMail
.To = "robe******#msn.com"
.CC = ""
.BCC = ""
.Subject = "Need Pick Face please!"
.Body = cel.Offset(0, -4).Value
.Display
End With
On Error GoTo 0
End If
Next cel
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Open a Word document from Excel and paste the contents to body of Outlook mail

I want, from Excel, to send automatic mails through MS Outlook.
The problem is writing the body of the mail. I have a separate Word file for each employee, with a hyperlink to it, in an Excel cell. I want to open the Word file and copy, with the same format, all which is in the Word document then paste into the body of the mail.
In my Excel workbook, columns A to E are as below.
Column A: Employee Name
Column B: To Mail ID
Column C: CC Mail ID
Column D: Subject
Column E: Hyperlink to Word file (Need to open the document to copy and paste the same in body of the mail)
Column F to Z: Attachment (Any type of attachment)
Sub Send_Files()
'Make a list in Sheets("Sheet1") with :
'In column A : Names of the people
'In column B : E-mail addresses
'In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
'The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
'and file name(s) in column C:Z it will create a mail with this information and send it.
'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
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 C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.cc = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = "Hi" & cell.Offset(0, -1).Value
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[enter link description here][1]
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Snap shot of the body of the mail content.
The trick is in getting the Word document contents pasted with the formatting. For that, you need to attach MS Word is the editor for an Outlook mail item.
Also, from your example Word doc above, you wanted the email to be personalized for the user. So modify the Word doc to read "Dear XXXNAMEXXX", then perform a find/replace (as shown in the code).
Option Explicit
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim OutMailEditor As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
Set WordApp = CreateObject("Word.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
'copy/paste the body of the email and change the name
Set OutMailEditor = OutMail.GetInspector.WordEditor
Set WordDoc = WordApp.documents.Open(Filename:=cell.Offset(0, 3).Value, ReadOnly:=True)
WordDoc.Content.Copy
OutMailEditor.Range.Paste
With OutMailEditor.Range.Find
.Text = "XXXNAMEXXX"
.Replacement.Text = cell.Offset(0, -1).Value
.Wrap = 1
.Forward = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With OutMail
.to = cell.Value
.cc = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
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
Set WordDoc = Nothing
End If
Next cell
Set OutApp = Nothing
Set WordApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Send Mail with email address in 4 columns

I send email with Ron de Bruin's script where it has option for sending of email address from column B value.
I have at least 4 columns of email address from column B to E. How can I modify this to send this e-mail?
Example:
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this: C:\Data\Book2.xls (doesn't have to be Excel files)
The macro will loop through each row in Sheet1 and if there is an e-mail address in column B and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2013
'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
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 C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
MASSIVE EDIT
As per your comment, the code below is changed. Should be working under the assumption that there is a filename in Column F. The lines to remove/comment out are marked in the code below in case you don't want this requirement.
Private Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'--BK201 mod: http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'
Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Dim FileCell As Range
Dim Rec As Range, RecRng As Range, RecList As Range, RecMail As Range
Dim FileRng As Range
Dim RecStr As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sh = ThisWorkbook.Sheets("Sheet1")
Set RecList = Sh.Range("B:B")
Set OutApp = CreateObject("Outlook.Application")
For Each Rec In RecList
With Sh
Set RecRng = .Range("B" & Rec.Row & ":E" & Rec.Row)
Set FileRng = .Range("F" & Rec.Row)
End With
RecStr = ""
For Each RecMail In RecRng
If RecMail.Value Like "?*#?*.?*" Then
RecStr = RecStr & RecMail.Value & ";"
End If
Next RecMail
If Len(FileRng.Value) > 0 Then '--Comment out if alright to send without attachment.
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = RecStr
.Subject = "Testfile"
.Body = "Hi " & Rec.Offset(0, -1).Value
On Error Resume Next
For Each FileCell In FileRng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display '.Send
End With
Set OutMail = Nothing
Else '--Comment out if alright to send without attachment.
Exit For '--Comment out if alright to send without attachment.
End If '--Comment out if alright to send without attachment.
Next Rec
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Set-up:
Result:
Hope this helps. :)