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
Related
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
Hi I am using below code to add chart and send email to multiple recipients. It works fine. In my sent item i can see a perfect email created and sent. But all the recipients are not able to see the charts. All they see is two red X
Sub Send_Email_Updated()
Dim olApp As Object
Dim NewMail As Object
Dim NewMail1 As Object
Dim ChartName As String
Dim ChartName1 As String
Dim SendingRng As Range
Dim htmlString As String
Dim OMail As Outlook.MailItem
Set wb = ActiveWorkbook
Set S1 = wb.Worksheets("Incident Tickets")
Set S2 = wb.Worksheets("Assets and Representatives")
Set S3 = wb.Worksheets("Email")
'Set SendingRng = Worksheets("Email").Table("A30:C43")
Set SendingRng = Worksheets("Email").Range("A30:C43")
Set olApp = CreateObject("Outlook.Application")
Set OMail = olApp.CreateItem(olMailItem)
' Group 1
If S3.Cells(7, 2) <> 0 Or S3.Cells(8, 2) <> 0 Or S3.Cells(9, 2) <> 0 Then
OMail.Display
'fill in the file path/name of the gif file app graph
ChartName = Environ$("Temp") & "\Chart 1.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 1").Chart.Export _
Filename:=ChartName, FilterName:="GIF"
'fill in the file path/name of the gif file trend graph
ChartName1 = Environ$("Temp") & "\Chart 31.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 31").Chart.Export _
Filename:=ChartName1, FilterName:="GIF"
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Action Required on Incidents and Problem Candidates for GC060.1 - Group 1"
.To = "animesh.das#xyz.com"
.HTMLBody =
"<img src=" & "'" & ChartName1 & "'>" & "<br/>" & "<br/>" & "_
"<img src=" & "'" & ChartName & "'>" & "<br/>" & "<br/>" & _
.Send
End With
ChartName = vbNullString
ChartName1 = vbNullString
End If
End Sub
I have to send reports to over 400 email addresses (on column B). The filepaths for each report are on columns C, D and E.
With this post: How to add default signature in Outlook the signature is added when the .display method is used.
The signature I want to show is for user number 1. I've selected the corresponding signature as a default signature for new messages.
This signature contains a picture, but this doesn't seem to cause any problems.
I wouldn't want the macro to show the mail every time it sends the mail, because I want to avoid the constant blinking on the screen.
I tried to look for something like "hide" method from here but didn't find anything useful (.display would run in the background, and it would stay hidden from the user). Other idea was to add application.screenupdating = false and correspondingly true in the end, but this didn't have any impact.
How could I display the email in the background without showing it every time to the user?
Sub sendFiles_weeklyReports()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim EmailCell As Range
Dim FileCell As Range
Dim rng As Range
Dim lastRow As Long
Dim timestampColumn As Long
Dim fileLogColumn As Long
Dim i As Long
Dim strbody As String
Dim receiverName As String
Dim myMessage As String
Dim reportNameRange As String
Dim answerConfirmation As Variant
Application.ScreenUpdating = False
Set sh = Sheets("Report sender")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
i = 0
reportNameRange = "C1:E1"
timestampColumn = 17 'based on offset on EmailCell (column B)!
fileLogColumn = 18 'based on offset on EmailCell (column B)!
myMessage = "Are you sure you want to send weekly reports?" & vbNewLine & "'" & _
sh.Range("C2").Value & "', " & vbNewLine & "'" & sh.Range("D2").Value & "' and " & vbNewLine & _
"'" & sh.Range("E2").Value & "'?"
answerConfirmation = MsgBox(myMessage, vbYesNo, "Send emails")
If answerConfirmation = vbYes Then
GoTo Start
End If
If answerConfirmation = vbNo Then
GoTo Quit
End If
Start:
For Each EmailCell In sh.Range("B3:B" & lastRow)
EmailCell.Offset(0, fileLogColumn).ClearContents
EmailCell.Offset(0, timestampColumn).ClearContents
Set rng = sh.Cells(EmailCell.Row, 1).Range(reportNameRange)
If EmailCell.Value Like "?*#?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
With OutMail
For Each FileCell In rng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then 'checks if there's a file path in the cell
.Attachments.Add FileCell.Value
EmailCell.Offset(0, fileLogColumn).Value = EmailCell.Offset(0, fileLogColumn).Value & ", " & _
Dir(FileCell.Value)
i = i + 1
End If
End If
Next FileCell
receiverName = EmailCell.Offset(0, -1).Value
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = EmailCell.Value
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
.display
.HTMLBody = strbody & .HTMLBody
.Send
EmailCell.Offset(0, timestampColumn).Value = Now
SkipEmail:
End With
Set OutMail = Nothing
End If
Next EmailCell
Set OutApp = Nothing
Application.ScreenUpdating = True
Call MsgBox("Weekly reports have been sent.", vbInformation, "Emails sent")
Quit:
End Sub
Appears .GetInspector has the same functionality of .Display except the "display".
Sub generateDefaultSignature_WithoutDisplay()
Dim OutApp As Object ' If initiated outside of Outlook
Dim OutMail As Object
Dim strbody As String
Dim receiverName As String
receiverName = const_meFirstLast ' My name
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
Set OutApp = CreateObject("Outlook.Application") ' If initiated outside of Outlook
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = const_emAddress ' My email address
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
' Default Signature
' Outlook 2013
' There is a report that .GetInspector is insufficient
' to generate the signature in Outlook 2016
'.GetInspector ' rather than .Display
' Appears mailitem.GetInspector was not supposed to be valid as is
' .GetInspector is described here
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim objInspector As Inspector
Set objInspector = .GetInspector
.HTMLBody = strbody & .HTMLBody
.Send
End With
ExitRoutine:
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
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