Add signature to email - excel

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

Related

Outlook embedded picture from Excel not showing in mail outside organisation

I am using a macro to compose a report based on an excel file. The macro uses a body with text and a picture (png) from an predefined Excel range.
This used to work perfect but now I have to share the report outside of my organization i get feedback that the image is not showing.
Does anybody know if this is due to the macro or not?
I have tested this also to my hotmail and gmail accounts and it is not showing there as well?
Sub Mail_()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim Adm As Worksheet
Dim Body As String
Dim Body2 As String
Dim Body3 As String
Dim Body4 As String
Dim rngToPicture As Range
Dim rng2 As Range
Dim Weeknr As String
Dim strTempFilePath As String
Dim strTempFileName As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set Adm = ActiveWorkbook.Worksheets("Uit")
Set rngToPicture = Adm.Range("X13:AT65")
Adm.Activate
ActiveWindow.Zoom = 100
strTempFileName = "RangeAsPNG"
Weeknr = Adm.Range("AF3").Text
Body = Adm.Range("X6:X6").Text
Body2 = Adm.Range("X8:X8").Text
Body3 = Adm.Range("X9:X9").Text
Body4 = Adm.Range("X11:X11").Text
strbody = "<BODY style=font-size:10pt;font-family:Verdana>" & Body & _
"<br><br>" & Body2 & "<br>" & Body3 & "<br><br>" & Body4 & "<br><br>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Handtekeningen\Servicekantoor.htm"
Signature = GetBoiler(SigString)
On Error Resume Next
With OutMail
.to = "Mailinglist#list.com"
.CC = ""
.BCC = ""
.Subject = "Weekly report " & Weeknr
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
.HTMLBody = strbody & "<br><br>" & "<img src='cid:" & strTempFileName & ".png'
style='border:0'>" & "<br><br>" & Signature
.Recipients.ResolveAll
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You are close - the cid in the src attribute must be not the file name (which is not visible to the outside users), but some value that matches the PR_ATTACH_CONTENT_ID property on the attachment:
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
set Attach = .Attachments.Add(strTempFilePath, olByValue)
Attach.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001F", "MyCid"
.HTMLBody = strbody & "<br><br>" & "<img src='cid:MyCid' style='border:0'>" & "<br><br>" & Signature

How Can I Format this VBA Email

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.

How insert hyperlink from a column into Outlook email body

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.

Paste Excel range as picture into email body

My aim is to paste a range as an image into an Outlook email. I turned on the references in the VBA editor for MS Excel, Word and Outlook 15.0 as my latest version on my network.
I've spent hours looking through previously answered similar questions.
I cannot save the image as a temporary file/use html to reference the attachment as a solution due to other users not having access to specific drives where it would be temporarily saved if they ran the code on their own machines.
If I remove the email body section the image pastes fine however if I have both pieces of code in together, the email body writes over the image. I do however need the image to be pasted within the email body text.
Sub CreateEmail()
Dim OlApp As Object
Dim OlMail As Object
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim PictureRange As Range
Dim OApp As Object, OMail As Object, signature As String
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.createitem(olmailitem)
ExtractName = ActiveWorkbook.Sheets("macros").Range("C11").Value
ToRecipient = ActiveWorkbook.Sheets("macros").Range("K11")
OlMail.Recipients.Add ToRecipient
CC_Check = ActiveWorkbook.Sheets("macros").Range("k10")
If CC_Check = "" Then GoTo Skip_CC
CcRecipient = ActiveWorkbook.Sheets("macros").Range("K10")
OlMail.Recipients.Add CcRecipient
OlMail.Subject = ExtractName
signature = OlMailbody
With OlMail
Set PictureRange = ActiveWorkbook.Sheets("DCTVV").Range("A2:D13")
PictureRange.Copy
OlMail.Display
'This section pastes the image
Dim wordDoc As Word.Document
Set wordDoc = OlMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
'This section is the email body it needs inserting into
OlMail.body = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
"IMAGE NEEDS TO BE PASTED HERE" _
& vbNewLine & vbNewLine & "More text here" _
& vbNewLine & vbNewLine & "Kind regards,"
.signature
End With
Set OMail = Nothing
Set OApp = Nothing
OlMail.Attachments.Add ("filepath &attachment1")
OlMail.Attachments.Add ("filepath &attachment2")
'OlMail.Attachments.Add ("filepath &attachment3")
OlMail.Display
End Sub
From what I understand the picture pastes fine to email's body, right?
In this case you might just need to add .HTMLBody like so:
olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
.HTMLBody & _
vbNewLine & vbNewLine & "More text here" & _
vbNewLine & vbNewLine & "Kind regards,"
This is an example of my code that we use on my job te send emails:
Call CrearImagen
ReDim myFileList(0 To Contador - 1)
For i = 0 To Contador - 1
myFileList(i) = wb.Path & "\" & Servicio & i & ".jpg"
ImagenesBody = ImagenesBody & "<img src='cid:" & Servicio & i & ".jpg'>"
Next i
With OutMail
.SentOnBehalfOfName = "ifyouwanttosendonbehalf"
.Display
.To = Para
.CC = CC
.BCC = ""
.Subject = Asunto
For i = 0 To UBound(myFileList)
.Attachments.Add myFileList(i)
Next i
Dim Espacios As String
Espacios = "<br>"
For i = 0 To x
Espacios = Espacios + "<br>"
Next
.HTMLBody = Saludo & "<br><br>" & strbody & "<br><br><br>" _
& ImagenesBody _ 'here are the images
& Espacios _ 'more text
& .HTMLBody
.Display
End With
On Error GoTo 0
'Reformateamos el tamaño de las imagénes y su posición relativa al texto
Dim oL As Outlook.Application
Set oL = GetObject("", "Outlook.application")
Const wdInlineShapePicture = 3
Dim olkMsg As Outlook.MailItem, wrdDoc As Object, wrdShp As Object
Set olkMsg = oL.Application.ActiveInspector.CurrentItem
Set wrdDoc = olkMsg.GetInspector.WordEditor
For Each wrdShp In wrdDoc.InlineShapes
If wrdShp.Type = wdInlineShapePicture Then
wrdShp.ScaleHeight = 100
wrdShp.ScaleWidth = 100
End If
If wrdShp.AlternativeText Like "cid:Imagen*.jpg" Then wrdShp.ConvertToShape
Next
'Limpiamos los objetos
For i = 0 To UBound(myFileList)
Kill myFileList(i)
Next i
Set olkMsg = Nothing
Set wrdDoc = Nothing
Set wrdShp = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Now if you can already create the images, just save them on the workbook path and you can attach them like this. When attaching images I suggest you that the names of the files don't contain spaces, found out this the hard way until figured it out, html won't like them with spaces.
If your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
As the VBA code below use 'Late Binding', it's also compatible with all previous and current versions of MS Office viz. Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub

Modify email sending macro to include attachment

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

Resources