How to embed pictures in an Outlook Email using Excel VBA? - excel

I need to embed two pictures in the email body (it doesn't matter if I attach them too).
This code attaches, but it doesn't embed.
'Attach(0)' means full path of 1st pic
'Attach(1)' means full path of 2nd pic
'Temp(0) means "shortname1.jpg"
'Temp(1) means "shortname2.jpg"
Dim Temp(1) As String
Temp(0) = Replace(Attach(0), ruta & "\", "")
Temp(1) = Replace(Attach(1), ruta & "\", "")
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = Email
.CC = CopyEmail
.Subject = Localidad & " " & "- Pay Period " & Format(Semana, "DD-MMM-YYYY") & " " & "Report"
.Attachments.Add lnvo
.Attachments.Add Attach(0), 1
.Attachments.Add Attach(1), 1
.HTMLBody = "<html><p>Charts</p>" & "<img src=""cid:" & Temp(0) & """height=520 width=750>" & "<img src=""cid:" & Temp(1) & """height=520 width=750>"
.Body = Msg
.Send
'
End With

Based on #ChrisFNZ and #braX comments, going up and down, I removed '.Body' and I inserted the '.Body' Text in the 'HTMLBody' ('Msg' Variable).
In the other hand, I decided to insert the double quotes in the Temp() variables. and it worked perfectly.
Dim Temp(1) As String
Temp(0) = Replace(Attach(0), ruta & "\", "") & """"
Temp(1) = Replace(Attach(1), ruta & "\", "") & """"
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = Email
.CC = CopyEmail
.Subject = Localidad & " " & "- Pay Period " & Format(Semana, "DD-MMM-YYYY") & " " & "Report"
.Attachments.Add lnvo
.Attachments.Add Attach(0), 1
.Attachments.Add Attach(1), 1
.HTMLBody = "<html><p" & Msg & "</p>" & "<img src=""cid:" & Temp(0) & " height=150 width=750>" & "<img src=""cid:" & Temp(1) & " height=150 width=750>"
'.Body = Msg
.Send
End With
Thanks everyone!

Related

Loop through rows to populate Email body

My current working Macro is:
Sub emailGenerator()
'Disable Screen Updating
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Email").Activate
Worksheets("Email").Visible = False
'ThisWorkbook.Sheets("P6").Activate
ActiveWorkbook.Save
Worksheets("Email").Visible = True
ThisWorkbook.Sheets("Email").Activate
Dim TempFilePath As String
Dim nameOfProject As String
Dim firstName As String
nameOfProject = Cells(3, 7)
firstName = Cells(4, 7)
'Create a new Microsoft Outlook session
Set appOutlook = CreateObject("outlook.application")
'create a new message
Set Message = appOutlook.CreateItem(olMailItem)
With Message
.Subject = nameOfProject & " Programme Analytical Tool"
.HTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hi " & firstName & ",<br ><br >Please find attached the analytical tool for " & nameOfProject & ". Commentary below:" _
& "<br><br>" & " - " & Cells(7, 2) _
& "<br>" & " - " & Cells(9, 2) _
& "<br>" & " - " & Cells(11, 2) _
& "<br>" & " - " & Cells(13, 2) _
& "<br>" & " - " & Cells(15, 2) _
& "<br>" & " - " & Cells(17, 2) _
& "<br>" & " - " & Cells(19, 2) _
& "<br>" & " - " & Cells(21, 2) _
& "<br>" & " - " & Cells(23, 2) _
& "<br>" & " - " & Cells(25, 2) _
& "<br>" & " - " & Cells(27, 2) _
& "<br>" & " - " & Cells(29, 2) _
& "<br>" & " - " & Cells(31, 2) _
& "<br><br><BR>"
'first we create the image as a JPG file
'Call createJpg("GRAPHS", "B2:AA90", "OFGraph")
'we attached the embedded image with a Position at 0 (makes the attachment hidden)
TempFilePath = Environ$("temp") & "\"
'.attachments.Add TempFilePath & "OFGraph.jpg", olByValue, 0
.attachments.Add ActiveWorkbook.FullName
'.attachments.Add "\\MSQFDC02\DFSRoot$\NW\NW08Groups\LNW North ASM Team\Incident Management Specialist\OUTSTANDING FAULT SUMMARIES\UNVERIFIED & OUTSTANDING FAULT SUMMARYs\DELIVERY UNITs\Closing of Faults Form.docx"
'Then we add an html <img src=''> link to this image
'Note than you can customize width and height - not mandatory
'.HTMLBody = .HTMLBody _
'& "<img src='cid:OFGraph.jpg'" & "width='1100' height='1120'><br>"
' & "<img src='cid:OFGraph.jpg'" & "width='1400' height='1420'><br>"
.To = firstName
.CC = ""
.Display
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I want to make those lines that are under the .HTMLBody more dynamic so I can add in more lines in the Excel sheet without having to re-visit the macro and tell it to read this specific line.
" & "" & " - " & Cells(x, 2) _"
Here's my attempt to make it dynamic and adding a loop, but not sure where it went wrong and it's highlighted as red.
This is how the sheet looks like:

Call subroutine

I am trying to send an email if a condition is met, and it is not working.
If cell D26 on the "Input" tab = "SEND TO OFFICE TO CREATE A BACKORDER", I want to call email, then save the record. The record saving works, but it is not emailing. Thank you in advance!
If CS.Range("D26").Value = "DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES" Then
MsgBox ("DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER. NOTHING IS REQUIRED OF YOU FOR THIS ITEM." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES. NO SE REQUIERE NADA DE USTED PARA ESTE ARTÍCULO")
End If
If CS.Range("D26").Value = "SEND TO OFFICE TO CREATE A BACKORDER." & vbCrLf & " " & vbCrLf & "ENVIAR A OFICINA PARA CREAR UN PEDIDO PENDIENTE" Then
Call Email
lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1
End If
lr = PS.Cells(Rows.Count, 1).End(xlUp).Row + 1
ArSourceAddress = Array("M4", "G4", "D17", "G14", "G7", "M7", "P7", "G11", "D26", "M14", "G20")
For I = 0 To UBound(ArSourceAddress)
PS.Cells(lr, I + 1).Value = CS.Range(ArSourceAddress(I)).Value
Next
PS.Cells(lr, 12).Resize(, 4).Value = CS.Range("S24").Resize(, 4).Value
PS.Cells(lr, 16).Resize(, 2).Value = CS.Range("X24").Resize(, 2).Value
MsgBox "THE RECORD HAS BEEN SAVED." & vbCrLf & " " & vbCrLf & "EL REGISTRO SE HA GUARDADO."
End Sub
Sub Email ()
Dim oApp As Object
Dim oMail As Object
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.CreateItem(0)
With OutlookMail
.To = "dmrubin25#gmail.com"
.CC = "dmrubin25#gmail.com"
.BCC = "dmrubin25#gmail.com"
.Subject = "ACTION REQUIRED: ENTER A BACKORDER" & CS.Range("G4").Value & "PO Number " & CS.Range("G20")
.BodyFormat = olFormatHTML
.HTMLBody = "Please create a backorder for the following:" & vbNewLine & vbNewLine & "Customer: " & CS.Range("G4").Value & vbNewLine & _
"Customer #: " & CS.Range("M4").Value & vbNewLine & "Quantity: " & CS.Range("R8").Value & vbNewLine & "PO Number: " & CS.Range("G20").Value & _
vbNewLine & vbNewLine & "Contact for Questions: " & CS.Range("M14").Value
.send
End With

Input cell data from Excel into Outlook

I'm looking to make an automated email script using vba to read from an Excel spreadsheet; the email address and dates (that sort of thing) then place them into the correct fields to send
It would be preferable if it could also finish the line of the spreadsheet and start a new one with a new email
I can currently make an email with vba but that's about it and manually dictate the fields within the script but that's about it. Any help on how to input cell data automatically would be much appreciated.
Thanks :)
Edit 1:
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & Range("C" & Line).Value & " " & Range("B" & Line).Value & " - " & Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & Range("C" & Line).Value & " " & Range("B" & Line).Value & "'s appointment with Dr " & Range("E" & Line).Value & " on " & Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
This seems to be the solve in case anyone has the same issue.
Thanks
The below code is more specific when defining the cells, which worked during my testing.
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = ws.Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & " - " & ws.Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & ws.Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & "'s appointment with Dr " & ws.Range("E" & Line).Value & " on " & ws.Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub

How to add or remove spaces between lines of text in an email?

I create an Outlook email and I want to add or remove spaces between paragraphs.
I tried using vbNewLine as well as " " but neither make an empty line.
Additionally, there is a large space after each bullet point for sentences created by my for loop. It is not an empty line, but rather the spacing Before and After the sentence (looking at the Paragraph menu) is set to "Auto" and I would like both to be "0".
Sub Email_Budget()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim CaseCount As Long
CaseCount = WorksheetFunction.CountA(Range("B6:B500"))
'Debug.Print CaseCount
Dim i As Integer
With objEmail
.To = "abc#xyz.com"
.Subject = "TEST1: May 2019 Budget"
.HTMLBody = "Karen,"
.HTMLBody = .HTMLBody & vbNewLine
.HTMLBody = .HTMLBody & "The potential " & _
MonthName(Month(ActiveSheet.Range("A2"))) & " invoices are below."
.HTMLBody = .HTMLBody & vbNewLine
For i = 1 To CaseCount
If ActiveSheet.Cells(i + 5, 4).Value = "Yes" Then
.HTMLBody = .HTMLBody & "<ul style='list-style-type:disc;'>" & "<li>" & _
ActiveSheet.Cells(i + 5, 2).Value & " - " & _
Format(ActiveSheet.Cells(i + 5, 6).Value, "Currency") & _
" (" & Format(ActiveSheet.Cells(i + 5, 8).Value, "Currency") & _
" without budget or invoicing)." & "</li>" & _
"<ul style = 'list-style-type:circle;'>" & "<li>" & "Last billed " & _
ActiveSheet.Cells(i + 5, 10) & "." & "</li>" & "</ul>" & "</ul>"
End If
Next i
.HTMLBody = .HTMLBody & vbNewLine
.HTMLBody = .HTMLBody & vbNewLine
.HTMLBody = .HTMLBody & "Thank you,"
.HTMLBody = .HTMLBody & vbNewLine
.HTMLBody = .HTMLBody & "Kurt"
.Display
End With
End Sub
perhaps use a line break element (br)?
Line 1<br>
Line 2
This should do what you're looking for:
Sub Email_Budget()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim CaseCount As Long
CaseCount = WorksheetFunction.CountA(Range("B6:B500"))
'Debug.Print CaseCount
Dim i As Integer
With objEmail
.To = "abc#xyz.com"
.Subject = "TEST1: May 2019 Budget"
.HTMLBody = "Karen,<br><br>"
.HTMLBody = .HTMLBody & "The potential " & MonthName(Month(ActiveSheet.Range("A2"))) & " invoices are below.<br>"
For i = 1 To CaseCount
If ActiveSheet.Cells(i + 5, 4).Value = "Yes" Then
.HTMLBody = .HTMLBody & Application.Trim("<ul style='list-style-type:disc;'><li style=""Margin: 0;"">" & ActiveSheet.Cells(i + 5, 2).Value & " - " & Format(ActiveSheet.Cells(i + 5, 6).Value, "Currency") & " (" & Format(ActiveSheet.Cells(i + 5, 8).Value, "Currency") & " without budget or invoicing).</li><ul style = 'list-style-type:circle;'><li style=""Margin: 0;"">Last billed " & ActiveSheet.Cells(i + 5, 10) & ".</li></ul></ul>")
End If
Next i
.HTMLBody = .HTMLBody & "<br>Thank you,<br>Kurt"
.Display
End With
End Sub

How to generate an email from Excel which takes into account however many rows are selected

I'm trying to generate an email from data input on to a spreadsheet, to create an offer of work. We have a list of work and assign it to someone.
At the moment with my code below, I can send one offer per email by selecting the row with the work, and pressing the command button.
However, I might be offering someone up to 4 pieces of work, and ideally I would like be able to edit this code to include all rows selected.
Does anyone have any suggestions?
Private Sub Generate_offer()
Dim strFile As String
Dim OutApp As Object
Dim objOutlookMsg As Object
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(0)
With objOutlookMsg
.SentOnBehalfOfName = ""
.to = ""
.Subject = ""
.HTMLBody = "<p style='font-family:arial;font-size:16'> Dear <br/><br/>
[Body of email - CUT]
& "<p style='font-family:arial;font-size:14'><b>Offer</b>: " & Cells(ActiveCell.Row, "C").Value & "<br/>" _
& "<b>Dates</b>: " & Cells(ActiveCell.Row, "L").Value & " - " & Cells(ActiveCell.Row, "M").Value & "<br/>" _
& "<b>Approx. duration</b>: " & Cells(ActiveCell.Row, "P").Value & " weeks" & "<br/>" _
& "<b>Detils</b>: xxxxx - " & Cells(ActiveCell.Row, "F").Value & "; xxxxx - " & Cells(ActiveCell.Row, "G").Value & "; xxxxx - " & Cells(ActiveCell.Row, "H").Value & "<br/><br/>" & vbNewLine _
[Body of email - CUT]
.display
End With
'objOutlookMsg.Send
Set OutApp = Nothing
End Sub
Any help much appreciated.
Notice a couple things in the example below...
(Almost) never use Select. Your code is one case where you are requiring the user to select a set of offers in order to run the macro. The Selection only appears on one line though. The rest of the code only uses the established range variable offers.
Make sure your ranges are always fully qualified. For you, this means not using Cells all by itself but setting up a range variable (offers in my example) that is fully qualified and using that as the base for all your Cells references.
It would look something like this:
Private Sub Generate_offer()
Dim strFile As String
Dim OutApp As Object
Dim objOutlookMsg As Object
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(0)
With objOutlookMsg
.SentOnBehalfOfName = ""
.To = ""
.Subject = ""
.HTMLbody = "<p style='font-family:arial;font-size:16'> Dear <br/><br/> "
.HTMLbody = .HTMLbody & "[Body of email - CUT]"
'--- assumes that the active selection is a set of rows,
' each row with unique offer details
Dim offers As Range
Set offers = ActiveSheet.Range.Selection
Dim i As Long
For i = 1 To offers.Rows.Count
.HTMLbody = .HTMLbody & "<p style='font-family:arial;font-size:14'><b>Offer</b>: "
.HTMLbody = .HTMLbody & offers.Cells(i, "C").Value & "<br/>"
.HTMLbody = .HTMLbody & "<b>Dates</b>: " & offers.Cells(i, "L").Value
.HTMLbody = .HTMLbody & " - " & offers.Cells(i, "M").Value & "<br/>"
.HTMLbody = .HTMLbody & "<b>Approx. duration</b>: " & offers.Cells(i, "P").Value
.HTMLbody = .HTMLbody & " weeks" & "<br/>"
.HTMLbody = .HTMLbody & "<b>Details</b>: xxxxx - " & offers.Cells(i, "F").Value
.HTMLbody = .HTMLbody & "; xxxxx - " & offers.Cells(i, "G").Value
.HTMLbody = .HTMLbody & "; xxxxx - " & offers.Cells(i, "H").Value
.HTMLbody = .HTMLbody & "<br/><br/>" & vbNewLine
Next i
.HTMLbody = .HTMLbody & [Body of email - CUT]
.display
End With
'objOutlookMsg.Send
Set OutApp = Nothing
End Sub

Resources