Add a range as a image - excel

I want to add a range as image in my code. the range should be from A1 to d30, i would like to add it after this line:
Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine
This is my code:
Sub EnviarEmail()
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Asunto As String
Dim Correo As String
Dim Destinatario As String
Dim Saldo, A As String
Dim Msg As String
If Range("f3") = 1 Then
salso = "Buena tarde,"
End If
If Range("f3") = 2 Then
salso = "Buena noche,"
End If
If Range("f3") = 3 Then
salso = "Buen día,"
End If
Set OutlookApp = New Outlook.Application
'
For Each cell In Range("w1")
'
Asunto = "Constancia de entregas"
Correo = cell.Value
Saldo = salso
FechaVencimiento = Now
A = Range("d4")
Msg = Saldo & vbNewLine & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & "Adjunto constancia de entregas del dia "
Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & "Saludos," & vbNewLine & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & A & vbNewLine
Msg = Msg & "Control de Calidad y Entregas" & vbNewLine & "Ext 210" & vbNewLine
Msg = Msg & "Goodyear Rubber & Tire Co" & vbNewLine
Msg = Msg & "www.goodyear.com" & vbNewLine
'
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = xxxx
.CC = xxxx
.Subject = Asunto
.Body = Msg
.Attachments.Add ActiveWorkbook.FullName
.Send
'
End With
'
Next
'
End Sub

You can use CopyPicture method to copy a range as an image.
And you can use WordEditor to edit a message as rich text.
' ...
For Each cell In Range("w1")
'
Asunto = "Constancia de entregas"
Correo = cell.Value
Saldo = salso
FechaVencimiento = Now
A = Range("d4")
'
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = "ktgk.chr66g#gmail.com"
.CC = "ktgk.chr66g#gmail.com"
.Subject = Asunto
.Attachments.Add ActiveWorkbook.FullName
.Display False
With .GetInspector.WordEditor.Windows(1).Selection
.Font.Name = "Calibri"
.Font.Size = "11"
Msg = ""
Msg = Saldo & vbNewLine & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & "Adjunto constancia de entregas del dia "
Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine
.TypeText Msg
.TypeText Chr(13)
' Copy & paste a range as an image
Range("A1:D30").CopyPicture
.Paste
.TypeText Chr(13)
Msg = ""
Msg = Msg & "Saludos," & vbNewLine & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & A & vbNewLine
Msg = Msg & "Control de Calidad y Entregas" & vbNewLine & "Ext 210" & vbNewLine
Msg = Msg & "Goodyear Rubber & Tire Co" & vbNewLine
Msg = Msg & "www.goodyear.com" & vbNewLine
.TypeText Msg
End With
.Send
'
End With
'
Next
'
' Make sure messages are sent
OutlookApp.GetNamespace("MAPI").SendAndReceive True

Related

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

excel vba send email with embed image

I used below macro to create email with embedded picture but it didn't work, as I kept on receiving
run time error 5 "Invalid procedure call or argument"
and highlighted this code .BodyFormat = olFormatHTML.
Sub Outlook_Email_With_Inline_Image()
'Add reference to Microsoft Outlook Object Library
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'Dim OutApp As Outlook.Application
'Dim oOutlookEmail As Outlook.MailItem
'Create New Outlook Email Item to Attach Image(s)
Set OutApp = CreateObject("Outlook.Application")
Set oOutlookEmail = OutApp.CreateItem(0)
'Actual Excel VBA to send email with Embedded images
With oOutlookEmail
.To = "user#gmail.com"
.CC = ""
.BCC = ""
.Subject = "Congrats"
.BodyFormat = olFormatHTML
.Attachments.Add "C:\Users\Username\Pictures\Michael's Email Promotion\Angela.jpg", olByValue, 0
sImgName = "ImageFile.img"
.HTMLBody = "<img src='cid:" & sImgName & "'" & " ><br>" 'Mention only the image file name not its path
'Or Use this below line.
'.HTMLBody = "<img src='" & sImgName & "'" & " ><br>"
.Display
' .Send 'or just put .Display to check
End With
Set OutlookMail = Nothing
Set OutApp = Nothing
End Sub
Sub email()
Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailSig As String
For Each ToCc In ActiveSheet.[A2:A2]
'=============================================================
Dim ToEmail, CcEmail, ToNm, CcNm As String
Dim DescrDt, DescrID, DescrNm As String
ToNm = Cells(ToCc.Row, [C1].Column).Value
CcNm = Cells(ToCc.Row, [G1].Column).Value
ToEmail = Cells(ToCc.Row, [E1].Column).Value
CcEmail = Cells(ToCc.Row, [I1].Column).Value
DescrID = Cells(ToCc.Row, [B1].Column).Value
DescrNm = Cells(ToCc.Row, [D1].Column).Value
DescrDt = "20190426"
'=============================================================
'''determine strBody --email message
Dim strFontSize, strFontName, strFontColor As String
strFontName = "Arial"
strFontColor = fAggieGray
strFontSize = 13
Greeting = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
Application.WorksheetFunction.Proper(ToNm) & "," & "<br> <br>" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>"
emailSig = "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
"<br> <br>" & "- OE & HRIS Team" & "<br>" & "______________________" & "<br> <br>" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>" & _
"<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size: 10px;"">" & _
"<span style=""color:" & strFontColor & """>" & _
"[Email generated through Excel Macros and Google meme download - source data: October 3, 2019]" & _
"</span style=""color:" & strFontColor & """>" & "</BODY>"
Set colAttach = oEmail.Attachments
Set oAttach1 = colAttach.Add("C:\Users\AA.jpg")
Set oAttach2 = colAttach.Add("C:\Users\BB.png")
Set oAttach3 = colAttach.Add("C:\Users\CC.jpg")
Set oAttach4 = colAttach.Add("C:\Users\DD.gif")
Set oAttach5 = colAttach.Add("C:\Users\EE.png")
Set oAttach6 = colAttach.Add("C:\Users\FF.jpg")
Set oAttach7 = colAttach.Add("C:\Users\GG.jpg")
Set olkPA1 = oAttach1.PropertyAccessor
Set olkPA2 = oAttach2.PropertyAccessor
Set olkPA3 = oAttach3.PropertyAccessor
Set olkPA4 = oAttach4.PropertyAccessor
Set olkPA5 = oAttach5.PropertyAccessor
Set olkPA6 = oAttach6.PropertyAccessor
Set olkPA7 = oAttach7.PropertyAccessor
olkPA1.SetProperty PR_ATTACH_CONTENT_ID, "AA.jpg"
olkPA2.SetProperty PR_ATTACH_CONTENT_ID, "BB.png"
olkPA3.SetProperty PR_ATTACH_CONTENT_ID, "CC.jpg"
olkPA4.SetProperty PR_ATTACH_CONTENT_ID, "DD.gif"
olkPA5.SetProperty PR_ATTACH_CONTENT_ID, "EE.png"
olkPA6.SetProperty PR_ATTACH_CONTENT_ID, "FF.jpg"
olkPA7.SetProperty PR_ATTACH_CONTENT_ID, "GG.jpg"
oEmail.Close olSave
oEmail.HTMLBody = Greeting & "<BODY style=" & Chr(34) & "font-family:" & strFontName & "; font-size:" & strFontSize & Chr(34) & ">" & _
"<span style=""color:" & strFontColor & """>" & _
"<br> <br>" & _
"<img src=""cid:FF.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:AA.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:BB.png""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:DD.gif""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:GG.jpg""height=520 width=750>" & _
"<br> <br>" & "<img src=""cid:EE.png""height=520 width=750>" & _
"</body>"
oEmail.Save
oEmail.To = "MM#email.com"
oEmail.CC = "AA#email.com"
oEmail.Subject = "Congrats " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
oEmail.display
'oEmail.send
NEXT_ToCC:
Set aEmail = Nothing
Set olInsp = Nothing
Set myDoc = Nothing
Set oRng = Nothing
Next ToCc
'oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
If you're using late-binding, then you can't use members of the Outlook OlBodyFormat enum.
olFormatHTML corresponds to 2.
Sub Outlook_Email_With_Inline_Image()
Const olFormatHTML As Long = 2
...
.BodyFormat = olFormatHTML
...
End Sub
Also - add Option Explicit to the top of your module and declare all variables.

Excel VBA to loop data into email body

I am trying to create a loop within VBA to have multiple selections from userform1's listbox2 when I hit the command button to draft an email with each selection in the following format. However, I can't figure out how to get more than just one selection into the body of the email. I tried to separate it into a "midbody" and add the code again, but it just adds the same entry twice. How can I make this loop work?
Private Sub CommandButton3_Click()
Dim objOutlook As Object
Dim objMail As Object
Dim midBody As String
Dim wksheet As String
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
wksheet = ListBox2.List(i)
Sheets(wksheet).Activate
End If
If wksheet = "" Then
MsgBox "Nothing is Selected"
objMail.To = "myemail#me.com"
'objMail.CC =
objMail.Subject = ""
Else
midBody = activesheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
activesheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & activesheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & activesheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & activesheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & activesheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & activesheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & activesheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & activesheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
objMail.body = midBody & Sheets.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
Sheets.Range("D" & Rows.Count).End(xlUp).Value & " through " & Sheets.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & Sheets.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & Sheets.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & Sheets.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & Sheets.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & Sheets.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & Sheets.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
End If
i = i + 1
Next i
objMail.Save
'Close the object
Set objMail = Nothing
MsgBox "Done", vbInformation
End Sub
I have made some changes in your code .Shifted Next of For towards later part of the code to include processing of loop. Removed redundant midBody.
Try This:
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim i As Integer
Dim Agent As String
Dim EmailID As String
Dim wksheet As String
Dim objOutlook As Object
Dim objMail As Object
With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) Then
wksheet = .List(i)
Exit For
End If
End With
If wksheet = "" Then
MsgBox "Nothing is Selected", vbExclamation
Exit Sub
End If
'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
r = Application.Match(Agent, mySheet.Columns(1), 0) 'choose one as per your data structure
Set ws = ThisWorkbook.ActiveSheet
'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "myemail#me.com" ' Or EmailID
' .CC =
.subject = ""
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
'.Display
'.Send
.Save
End With
Next i
Set objMail = Nothing
Set objOutlook = Nothing
MsgBox "Done", vbInformation
End Sub
EDIT: Another version of code which works at my end. I have not created a listbox but simulated its working. This program loops correctly and send emails multiple times. Please remove k variable as per your listbox code . It is only for checking correct looping of the ptogram. Earlier version of program can be adjusted to your requirements if you provide sample data as what is the structure of listbox, from where it is picking emailid of the recipient, sample data of your worksheet etc.
Private Sub Command3_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim ws As Worksheet
Dim k As Integer
On Error Resume Next
Set ws = ThisWorkbook.ActiveSheet
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
k = 4 ' remove it only for checking correct loop
For intCurrentRow = 0 To k - 1 'List2.ListCount change k to List2.ListCount
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
' List2.Selected(intCurrentRow) = True ' This is to be commented out after trials for looping
.To = "abc#gmail.com"
.subject = "Test 2nd time Email"
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
.Send
End With
Next intCurrentRow
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Outlook snapshot shows it is looping properly which was your main problem.
EDIT2: Earlier version of program simulated at my end on sample basis is running correctly and sending multiple mails. I do not have idea of your data setup so simulated for looping which was your main problem. Please try the program as it is , retain a copy and then make suitable adjustments for your data specific situation.
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim i As Integer
Dim Agent As String
Dim EmailID As String
Dim wksheet As String
Dim objOutlook As Object
Dim objMail As Object
' With Me.ListBox2
For i = 1 To 3
'For i = 0 To .ListCount - 1
' If .Selected(i) Then
' wksheet = .List(i)
' Exit For
' End If
'End With
If wksheet = "hello" Then
MsgBox "Nothing is Selected", vbExclamation
Exit Sub
End If
'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
' r = Application.Match(Agent, mySheet.Columns(1), 0) 'choose one as per your data structure
Set ws = ThisWorkbook.ActiveSheet
'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "abc#gmail.com" ' Or EmailID
' .CC =
.subject = "original test"
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
'.Display
.Send
'.Save
End With
Next i
Set objMail = Nothing
Set objOutlook = Nothing
MsgBox "Done", vbInformation
End Sub

Automatic e-mail with changes in the body - VBA

I have to create a VBA to send automatic e-mails (the body of the e-mail links the recipient to a specific project that he is responsible for). The problem that I encountered is the fact that a certain recipient (i.e. placed in "TO") can be responsible for more tasks. The VBA that I am using sends emails to each task (even if the person is responsible for more). What can I do to count through recipients, if it's greater than 1 to send the e-mail which includes all of the tasks. I really need your help.
<PRE>Sub SendEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim lastRow As Long
Dim Ebody As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Ebody = "<FONT SIZE = 4 name = Arial>" & "Dear " & Cells(i, "A").Value
& "<br>" _
& "<br>" _
& "Please note that the below mentioned projectd are in scope for reporting." & "<br>" _
& "<br>" _
& Cells(i, "C").Value & " - " & Cells(i, "E").Value & "<br>" _
& "xxxxx will investigate and action your notification according to priority and to ensure public safety." & "<br>" _
& "For further information, please phone xxxxx on 6111 and quote reference number:" & "<br>" _
& "Your original report can be seen below:" & "</Font>" & "<br>" _
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Cells(i, "B").Value
.Cc = Cells(i, "D").Value
.Subject = "Your Registration Code"
.HtmlBody = Ebody
.Attachments.Add "C:\Test\Document.docx"
.Attachments.Add "C:\Test\Document1.docx"
.SentOnBehalfOfName = "Financial#yahoo.com"
.Display
End With
Next
End Sub </pre>
Sub Emailer()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, y, sbody
Dim eml As Worksheet, bd As Worksheet
Dim underlyingary, ISINarray, Accountarray, i
Set eml = Sheets("Emailer"): Set bd = Sheets("Body"): Set OutApp = CreateObject("Outlook.Application")
For Each y In eml.Range("A2:A" & eml.Range("A1000000").End(xlUp).Row)
If eml.Range("F" & y.Row) <> "" Then
underlyingary = Split(eml.Range("F" & y.Row), ",")
Accountarray = Split(eml.Range("G" & y.Row), ",")
ISINarray = Split(eml.Range("H" & y.Row), ",")
For i = 0 To UBound(underlyingary)
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(underlyingary(i))) & " Account Number: " & WorksheetFunction.Proper(Trim(Accountarray(i))) & " ISIN: " & WorksheetFunction.Proper(Trim(ISINarray(i))) & "<br>" & "<br>"
Next i
Else
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(eml.Range("C" & y.Row))) & " Account Number: " & WorksheetFunction.Proper(Trim(eml.Range("D" & y.Row))) & " ISIN: " & WorksheetFunction.Proper(Trim(eml.Range("E" & y.Row))) & "<br>"
End If
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = eml.Range("A" & y.Row)
.Subject = bd.Range("B2")
.cc = eml.Range("I" & y.Row)
.htmlBody = bd.Range("A2") _
& "<br>" & "<br>" & _
bd.Range("A3") & _
Trim(eml.Range("B" & y.Row)) & _
bd.Range("A4") _
& "<br>" & "<br>" & _
sbody _
& "<br>" & _
bd.Range("A5") _
& "<br>" & "<br>" & "<li>" & _
bd.Range("A6").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A7").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A8").Text & "</li>" & _
"<br>" & "<br>" & _
bd.Range("A9") _
& "<br>" & bd.Range("A10")
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Next y
cleanup:
Set OutApp = Nothing
End Sub

Bold Variables in Email body using Excel Visual Basic

This is actually my first time posting on this site - I really appreciate all the help I can get!
I have an Excel sheet that contains
clients emails,
their name,
their check dates and
and their processing date.
I want to send out a reminder email to them daily if their processing date is today. I've been successful in writing the code - but I haven't been able to bold parts of the email (ProcessingDate, CheckDate and Time).
Thank you so much again!
Here is my code:
Sub SendEm()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, MyDate As Date, Client As String, ProcessingDate As Date, CheckDate As Date, Time As Date, PayrollSpecialist As String
Dim Msg As Variant
lr = Sheets("DataSheet").Cells(Rows.Count, "S").End(xlUp).row
Set Mail_Object = CreateObject("Outlook.Application")
MyDate = Date
For i = 2 To lr
Client = Sheets("DataSheet").Range("S" & i).Value
ProcessingDate = Sheets("DataSheet").Range("B" & i).Value
CheckDate = Sheets("DataSheet").Range("C" & i).Value
Time = Sheets("DataSheet").Range("A" & i).Value
PayrollSpecialist = Sheets("DataSheet").Range("D" & i).Value
If Sheets("DataSheet").Range("B" & i).Value = MyDate Then
Msg = "Dear" & " " & Client
Msg = Msg & Sheets("Email").Range("B2").Value
Msg = Msg & ProcessingDate & " "
Msg = Msg & Sheets("Email").Range("B3").Value
Msg = Msg & CheckDate
Msg = Msg & ". " & Sheets("Email").Range("B4").Value & " "
Msg = Msg & Time
Msg = Msg & " " & Sheets("Email").Range("B5").Value & Sheets("Email").Range("B6").Value & vbNewLine & PayrollSpecialist
With Mail_Object.CreateItem(o)
.Subject = Sheets("Email").Range("A2").Value
.To = Sheets("DataSheet").Range("T" & i).Value
.Body = Msg
'.Send
.display 'disable display and enable send to send automatically
End With
End If
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
You can use
.htmlBody rather than .Body
use html
So to bold ProcessingDate
Msg = Msg & "<b>" & ProcessingDate & "</b> "
For example with your code
Msg = "Dear" & " " & Client
'Msg = Msg & Sheets("Email").Range("B2").Value
Msg = Msg & "<b>" & ProcessingDate & "</b> "
'Msg = Msg & Sheets("Email").Range("B3").Value
Msg = Msg & CheckDate
'Msg = Msg & ". " & Sheets("Email").Range("B4").Value & " "
Msg = Msg & Time
'Msg = Msg & " " & Sheets("Email").Range("B5").Value & Sheets("Email").Range("B6").Value & vbNewLine & PayrollSpecialist
With Mail_Object.CreateItem(o)
.Subject = "tested"
.To = "someone#hotmail.com"
.htmlBody = Msg
'.Send
.display 'disable display and enable send to send automatically
End With

Resources