How can I add bold, underline, text color, and other text formatting to this email?
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
' Create a new Outlook object
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyR = Cells(iCounter, 42).Value
SafetySR = Cells(iCounter, 43).Value
SafetySS = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "Dear " & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyR & ";" & SafetySR & ";" & SafetySS
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.BodyFormat = 1 ' 1–text format of an email, 2-HTML format
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Body = strbody
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
I updated the code to this, but it is still only pulling the text inside the quotations instead of formatting the text. I'm not sure what is wrong! I appreciate the help!
They want me to add more detail to my post because it is mostly code so I am typing to fill in space. Not sure what else to fix in my code. Let me know what you think
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem, html As String
' Create a new Outlook object
For iCounter = 4 To Cells(Rows.Count, 1).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyReg = Cells(iCounter, 42).Value
SafetySubReg = Cells(iCounter, 43).Value
SafetySpec = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "<b> Dear </b>" & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "<p><b> Your site blah blah </b> blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "<u> blah blah </u>" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyReg & ";" & SafetySubReg & ";" & SafetySpec
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.Body = strbody
objOutlookMsg.BodyFormat = 2
'objOutlookMsg.HTMLBody = "<html><head></head><body>" & mailbody & "</body></html>"
objOutlookMsg.Attachments.Add "C:\Users
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
Here's a basic example:
Sub Example()
Dim OutApp As Outlook.Application
Dim msg As Outlook.MailItem, html As String
Set OutApp = CreateObject("Outlook.Application")
Set msg = OutApp.CreateItem(olMailItem)
msg.BodyFormat = olFormatHTML
msg.Subject = "Hello"
html = "<p>Dear person,</p>"
html = html & "<p><b>Please</b> <u>read</u> <i>this</i> "
html = html & "<span style='background-color:#F00'>important</span> mail.</p>"
html = html & "<p><span style='font-size:24pt'>right away</span></p>"
msg.HTMLBody = html
msg.Display
End Sub
You must use either olFormatRichText or olFormatHTML to format the body of your message. I would recommend using HTML. You can then construct an HTML string and reference that as your message.
This post gives an excellent example for you:
VBA Excel Outlook Email Body Formatting
P.S. Sorry. I don't usually read comments because they are typically unhelpful. I only just now saw the comments before. Did you set this line as in the example?:
.HTMLBody = "<html><head></head><body>" & mailbody & "</body></html>"
You must set the HTMLbody property for html formatting, NOT the .body property. You can also put the <html></html> tags in the message body itself instead of wrapping it like the example. The <head></head> tags are optional.
Related
I have the following code but I don't want my table to appear at the bottom of the body but instead in a specified place within the body of my email. I don't know VBA so I am struggling.
The email will be something like:
Dear Customer,
Paragraph 1
COPIED TABLE
Paragraph 2
Kind regards,
Sub Test_Click()
Dim outlook As Object
Dim newEmail As Object
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
With newEmail
.To = ""
.CC = ""
.BCC = ""
.Subject = Test
.Body = "Test"
.display
Dim xInspect As Object
Dim pageEditor As Object
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor
Sheet1.Range("T45:X51").Copy
pageEditor.Application.Selection.Start = Len(.Body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.Paste
Set pageEditor = Nothing
Set pageEditor = Nothing
End With
End Sub
What I usually do in such situation is to define a template for the email body, having variables at the place I want my data. And then I just to some replace()
Example:
Dim strTemplate as string
dim strVariable as string
strTemplate = "Dear Customer, " & vbcrlf & vbcrlf & _
"Paragraph 1" & vbcrlf & vbcrlf & _
"[[COPIED TABLE]] " & vbcrlf & vbcrlf & _
"Paragraph 2" & vbcrlf & vbcrlf & _
"Kind regards, " & vbcrlf
strVariable = Sheet1.Range("T45:X51")
With newEmail
.Body = Replace(strTemplate, "[[COPIED TABLE]]", strVariable)
much more easier, and you can deal that easily with any much variables/placeholders you want in your text
My code is looping through all rows except the last one. How can I fix it??
Sub Send_CPR_Expiration_Sites()
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim OutApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
' Create a new Outlook object
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
' Subject
strSubj = "Immediate Action Required: Out of Compliance for "
On Error GoTo dbg
' Create a new item (email) in Outlook
strbody = ""
SiteLead = Cells(iCounter, 41).Value
SafetyR = Cells(iCounter, 42).Value
SafetySR = Cells(iCounter, 43).Value
SafetySS = Cells(iCounter, 44).Value
SiteCode = Cells(iCounter, 6).Value
'Make the body of an email
strbody = "Dear " & SiteCode & " Team," & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "blah blah blah" & vbCrLf
strbody = strbody & vbCrLf
strbody = strbody & "Let us know if you have any questions. Thank you!"
strbody = strbody & vbCrLf
objOutlookMsg.To = SiteLead
objOutlookMsg.CC = SafetyR & ";" & SafetySR & ";" & SafetySS
objOutlookMsg.Importance = olImportanceHigh
objOutlookMsg.Subject = strSubj & SiteCode
objOutlookMsg.BodyFormat = 1
objOutlookMsg.Attachments.Add "C:\Users"
objOutlookMsg.Attachments.Add "C:\Users"
' 1 – text format of an email, 2 - HTML format
objOutlookMsg.Body = strbody
objOutlookMsg.Display
Next iCounter
dbg:
'Display errors, if any
If Err.Description <> "" Then MsgBox Err.Description
Set objOutlookMsg = Nothing
Set OutApp = Nothing
End Sub
For iCounter = 4 To WorksheetFunction.CountA(Columns(1))
If you had blanks in (eg) A1:A2 and data in A3:A20 then the loop is going to run from 4 to 18, not 4 to 20
This is a better way to set the end of the for loop:
For iCounter = 4 To Cells(rows.count, 1).End(xlUp).Row
I have column "AB" that has a hyperlink in which I will like to include in a email through VBA.
The hyperlink changes per line. I am able to pull the column through text however the email is not showing the hyper link.
How can I get it to show as a hyperlink?
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(FormulaCell.Row, "Y").Value
strcc = ""
strbcc = ""
strsub = "MCR FORM"
strbody = "Hi " & Cells(FormulaCell.Row, "O").Value & vbNewLine & vbNewLine & _
"You have a open MCR that needs attention. Please Find the attachted MCR Form for material : " & Cells(FormulaCell.Row, "E").Value & _
vbNewLine & vbNewLine & Cells(FormulaCell.Row, "AB").Value & vbNewLine & vbNewLine & "Thank you!"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
.Attachments.Add ("P:\Inventory Control\Public\MCR Form Master.xlsm")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
vbNewLine & vbNewLine & Cells(FormulaCell.Row, "AB").Value &
I believe the code above needs to be reference a HREF link??
Work with HTMLBody Property
Example will show Hyperlink Click Here
.HTMLBody = " Click Here "
Or This will show the value A1 as link
"" & Sht.Range("A1") & "" &
Full Code
Option Explicit
Public Sub Example()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = "Hi " & vbNewLine & vbNewLine & _
"You have a open MCR that needs attention. " & _
vbNewLine & vbNewLine & _
" Click Here " & _
vbNewLine & vbNewLine & _
"Thank you!"
'You can add a file to the mail like this
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Option Explicit Statement (Visual Basic)
Forces explicit declaration of all variables in a file, or allows implicit declarations of variables.
I'm trying to utilize my default signature when I send an automated email.
My code pastes the location of the signature rather than the signature itself.
Sub CreateEmailForGTB()
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("BBC").Copy After:=wb.Sheets(1)
'save the new workbook in a dummy folder
wb.SaveAs "location.xlsx"
'close the workbook
ActiveWorkbook.Close
'open email
Dim OutApp As Object
Dim OutMail As Object
Dim newDate: newDate = Format(DateAdd("M", -1, Now), "MMMM")
Dim sigstring As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
sigstring = Environ("appdata") & _
"\Microsoft\Signatures\zbc.htm"
'fill out email
With OutMail
.To = "abc#domain.com;"
.CC = "xyz#domain.com;"
.BCC = ""
.Subject = "VCR - CVs for BBC " & "- " & newDate & " month end."
.Body = "Hi all," & vbNewLine & vbNewLine & _
"Please fill out the attached file for " & newDate & " month end." & vbNewLine & vbNewLine & _
"Looking forward to your response." & vbNewLine & vbNewLine & _
"Many thanks." & vbNewLine & vbNewLine & _
sigstring
There's another way to grab to display the signature in a email message, that in easier to use in my opinion. It does require that you have set up your signature to display on new messages by default.
See the routine I have set up below for how to implement.
Sub SendMail(strTo As String, strSubject As String, strBody As String, strAttachments As String, Optional strCC As String, Optional strFolder As String, Optional blSend As Boolean)
'*******************************************************************
'** Sub: SendMail
'** Purpose: Prepares email to be sent
'** Notes: Requires declaration of Outlook.Application outside of sub-routine
'** Passes file name and folder for attachments separately
'** strAttachments is a "|" separated list of attachment paths
'*******************************************************************
'first check if outlook is running and if not open it
Dim olApp As Outlook.Application
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then Set olApp = New Outlook.Application
Dim olNS As Outlook.Namespace
Dim oMail As Outlook.MailItem
'login to outlook
Set olNS = olApp.GetNamespace("MAPI")
olNS.Logon
'create mail item
Set oMail = olApp.CreateItem(olMailItem)
'display mail to get signature
With oMail
.display
End With
Dim strSig As String
strSig = oMail.HTMLBody
'build mail and send
With oMail
.To = strTo
.CC = strCC
.Subject = strSubject
.HTMLBody = strBody & strSig
Dim strAttach() As String, x As Integer
strAttach() = Split(strAttachments, "|")
For x = LBound(strAttach()) To UBound(strAttach())
If FileExists(strFolder & strAttach(x)) Then .Attachments.Add strFolder & strAttach(x)
Next
.display
If blSend Then .send
End With
Set olNS = Nothing
Set oMail = Nothing
End Sub
You need to actually get the text from the file as opposed to just setting the filepath as a string like you are now. I'd suggest something like this:
Function GetText(sFile As String) As String
Dim nSourceFile As Integer, sText As String
''Close any open text files
Close
''Get the number of the next free text file
nSourceFile = FreeFile
''Write the entire file to sText
Open sFile For Input As #nSourceFile
sText = Input$(LOF(1), 1)
Close
GetText = sText
End Function
Source: http://www.exceluser.com/excel_help/questions/vba_textcols.htm
You can then simply use this in your code:
sigstring = GetText(Environ("appdata") & "\Microsoft\Signatures\zbc.htm")
Your variable sigstring literally is just the name of the file - you never read the file contents.
To read the contents try this (and don't forget to declare a variable (text and line in my example) to hold the file contents).
sigstring = Environ("appdata") & "\Microsoft\Signatures\zbc.htm"
Open sigstring For Input As #1
Do Until EOF(1)
Line Input #1, line
text = text & line
Loop
Close #1
You can add your default signature by entering the items .Display right after your With statements and adding .body on the body message. see below code
With OutMail
.Display
.To = "abc#domain.com;"
.CC = "xyz#domain.com;"
.BCC = ""
.Subject = "VCR - CVs for BBC " & "- " & newDate & " month end."
.Body = "Hi all," & vbNewLine & vbNewLine & _
"Please fill out the attached file for " & newDate & " month end." & vbNewLine & vbNewLine & .body
"Looking forward to your response." & vbNewLine & vbNewLine & _
"Many thanks." & vbNewLine & vbNewLine
I would like to modify this script to include an attachment in the email that it creates. Cell F5 on worksheet "Instructions" contains the file path. I've tried to modify it using information from several different sources.
Here is a working version, pre-attachment attempts:
Sub CreateMails()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As String
Dim rngAttach As Range
Dim SigString As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Worksheets("Data validation")
Set rngTo = .Range("J63")
Set rngSubject = .Range("J61")
strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"__________________________________" & vbNewLine & _
.Range("J67") & vbNewLine & vbNewLine & _
"My Company" & vbNewLine & _
"123 Address street" & vbNewLine & _
"City, State, Zip, USA" & vbNewLine & _
"Telephone:"
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.Save
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set strbody = Nothing
Set rngAttach = Nothing
End Sub
All you should need is:
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.attachments.Add Range("F5").Value 'add the attachment
.Save
End With
Using your code, this worked for me.
Hi I can share the below template code which i use for creating and attaching a sheet from my workbook as a PDF _ i've changed some of the "text" values but the rest is the same.
You could work with this to include the attachment, and send as xlsx if required.
Sub SendWorkSheetToPDF()
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet
Dim cell As Range
Dim strto As String
Dim Strcc As String
Application.ScreenUpdating = False
'To'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
If cell.Value Like "?*#?*.?*" Then
Strcc = Strcc & cell.Value & ";"
End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next
Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
"Please see attached daily " & vbNewLine & vbNewLine & _
"Kind Regards" & vbNewLine & _
" "
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub