VBA inserted HTML image not visible in Outlook by External Parties - excel

I believe in early 2020 outlook had an update that caused inserted HTML images to not be visible to external parties.
At my old company we had a developer who was able to write something that allowed the image to be visible. I wasn't, and am still not, well versed in coding and have been piecing together stuff, but I can't figure this one out. Not even sure where to start. Any ideas?
If any of the vba below can be cleaned up, please let me know.
Sub Email()
'Create and assign email variables
Dim OutApp As Object
Dim OutMail As Object
'Create and assign JPEF variable
Dim MakeJPG As String
'create and assign workbook variable
Dim wb As Workbook
'create and assign File path variable
Dim Filepath As String
'Create and assign File name variable
Dim Filename As String
'Create and assign File date variable
Dim Filedate As String
'Create and assign Folder Year variable
Dim folderyear As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Filepath = Format(Range("filepath"))
Filename = Format(Range("filename"))
Filedate = Format(Range("trade_date"), "ddmmmyyyy")
folderyear = Format(Range("trade_date"), "yyyy")
'========================================================================
'Copy range you want to paste on new worksheet
Worksheets("Sheet1").Range("A1:Q31").Copy
'Open new workbook
Set wb = Workbooks.Add
Application.DisplayAlerts = False
'paste copied range
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
ActiveSheet.Paste
'Adjust Window Zoom
ActiveWindow.Zoom = 80
'Adjust Gridlines
ActiveWindow.DisplayGridlines = False
'Adjust Header Row Height
Rows("2:5").Select
Selection.RowHeight = 25.5
Rows("6").Select
Selection.RowHeight = 21
'Adjust DA Sales Column Width
Columns("A").ColumnWidth = 6
Columns("B").ColumnWidth = 12
Columns("C").ColumnWidth = 14
Columns("D:E").ColumnWidth = 10
Columns("F").ColumnWidth = 39
Columns("G").ColumnWidth = 10
Columns("H").ColumnWidth = 16
'Adjust RT Sales Column Width
Columns("I").ColumnWidth = 4
Columns("J").ColumnWidth = 12
Columns("K").ColumnWidth = 14
Columns("L:M").ColumnWidth = 10
Columns("N").ColumnWidth = 39
Columns("O").ColumnWidth = 10
Columns("P").ColumnWidth = 16
Columns("Q").ColumnWidth = 6
'Rename worksheet
ActiveSheet.Name = "Sheet1"
'Save new worksheet with pasted range
wb.SaveAs Filename:=Filepath & Filename & " " & Filedate & ".xlsx"
Application.DisplayAlerts = True
'Close active workbook
ActiveWorkbook.Close True
'========================================================================
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'========================================================================
'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("Sheet1", "A1:Q31")
If MakeJPG = "" Then
MsgBox "Something went wrong, can't create email"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
'========================================================================
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.Display
End With
Signature = OutMail.HTMLBody
'========================================================================
'Define & Assign To email list using a named range
Set emailRng = Worksheets("Sheet1").Range("to_email")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
Set emailRng2 = Worksheets("Sheet1").Range("cc_email")
For Each cl2 In emailRng2
sCc = sCc & ";" & cl2.Value
Next
sCc = Mid(sCc, 2)
'========================================================================
With OutMail
.To = sTo '"Manually enter email address here"
.cc = sCc '"Manually enter email address here"
.BCC = ""
.Subject = Filename & " " & Range("trade_date")
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=1150 height=600></html>" & "<br><br>" & Signature & "<br><br>"
.Attachments.Add Filepath & Filename & " " & Filedate & ".xlsx"
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'========================================================================
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function

Create an HTML table from the range rather than an image attachment.
Option Explicit
Sub Email()
Const RNG_EMAIL = "A1:Q31"
Dim wb As Workbook, ws As Worksheet
Dim filepath As String, filename As String
Dim filedate As String, FolderYear As String
Dim rng As Range, msg As String
Set ws = ThisWorkbook.Sheets("Sheet1")
filepath = Range("filepath")
filename = Range("filename")
filedate = Format(Range("trade_date"), "ddmmmyyyy")
FolderYear = Format(Range("trade_date"), "yyyy")
'Copy range you want to paste on new worksheet
Set rng = ws.Range(RNG_EMAIL)
rng.Copy
Set wb = Workbooks.Add(xlWBATWorksheet) ' one sheet
wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False
FormatSheet wb.Sheets(1)
With ActiveWindow
.Zoom = 80
.DisplayGridlines = False
End With
'Save new worksheet with pasted range and close
Application.DisplayAlerts = False
wb.SaveAs filename:=filepath & filename & " " & filedate & ".xlsx"
Application.DisplayAlerts = True
wb.Close False
' prepare and send email
msg = SendEmail(ws, rng)
MsgBox msg, vbInformation
End Sub
Function SendEmail(ws As Worksheet, rng As Range) As String
Const CSS = "body{font:12px Verdana};p{font:14px Verdana Bold};"
Dim OutApp As Object, OutMail As Object, cell As Range
Dim sTo As String, sCc As String
Dim signature As String, strbody As String
' some message text
strbody = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, " & _
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua"
'Define & Assign To email list using a named range
For Each cell In ws.Range("to_email")
sTo = sTo & ";" & cell.Value
Next
sTo = Mid(sTo, 2)
'Define & Assign CC email list
For Each cell In ws.Range("cc_email")
sCc = sCc & ";" & cell.Value
Next
sCc = Mid(sCc, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "My Company"
.BodyFormat = olFormatHTML
.To = sTo
.cc = sCc
.BCC = ""
.Subject = Range("filename") & " " & Range("trade_date")
signature = .HTMLBody
.HTMLBody = "<html><style>" & CSS & "</style><p>" & strbody & "</p>" & _
RngToHtml(rng) & "<br><br>" & signature & "</html>"
.Display 'or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
SendEmail = "Email sent to " & sTo
End Function
Function RngToHtml(rng As Range)
Dim t As String, r As Long, c As Long
For r = 1 To rng.Rows.Count
t = t & "<tr>"
For c = 1 To rng.Columns.Count
t = t & "<td>" & rng.Cells(r, c) & "</td>"
Next
t = t & "</tr>" & vbCrLf
Next
RngToHtml = "<table width=""1150"">" & t & "</table>"
End Function
Sub FormatSheet(ws As Worksheet)
Dim colWidth, c As Integer
'DA and RT Sales Column Width A-Q
colWidth = Array(6, 12, 14, 10, 10, 39, 10, 16, _
4, 12, 14, 10, 10, 39, 10, 16, 6)
With ws
.Rows("2:5").RowHeight = 25.5
.Rows("6").RowHeight = 21
For c = 0 To UBound(colWidth)
.Columns(c + 1).ColumnWidth = colWidth(c)
Next
End With
End Sub

Related

VBA: Emailing a different range image to each of the recipients

I'm trying to automate an emailing process with outlook.
So far my code enables to:
Send different attachments to different recipients
Send the same range of the excel sheet (ex: A1:B3) as an image in the email body to all the recipients
Personalized message
What I would like is to send different ranges to different recipients (like the attachments) for example:
Email 1: Range A1 B3
Email 2: Range A4:B7
Email 3: Range A8:B11
etc...
Is it possible to make it on loop or sth?
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim MakeJPG As String
Dim PictureRange As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
MakeJPG = CopyRangeToJPG("Sheet1", "F31: J37")
If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/>" & "<br/>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & "</p><img src=""cid:NamePicture.jpg"" width=550 height=150></html>" & "<p>" & "<\p>" & Range("B17") & .HTMLBody
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
Set the initial image range and then offset it after each email sent .
Set rngImage = sh.Range("F27:J28")
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
With the constant TEST = True this code should run without sending emails. If correct set TEST = False.
Option Explicit
Sub Send_Files()
Dim OutApp As Object, OutMail As Object
Dim ws As Worksheet, cell As Range, cellA, rngA As Range
Dim jpgFilename As String, filename As String, html As String
Dim rngImage As Range, sImage As String, n As Long
Const TEST = True ' set to False to use Outlook
Const IMG_NAME = "Image_"
Const IMG_RANGE = "F27:J28" ' first email
If Not TEST Then
Set OutApp = CreateObject("Outlook.Application")
End If
Set ws = Sheets("Sheet1")
Set rngImage = ws.Range(IMG_RANGE) ' first image
' scan column B for valid email addresses
For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rngA = cell.Offset(,1).Resize(, 24) ' C:Z attachments
If Application.WorksheetFunction.CountA(rngA) = 0 Then
' no attachments - do nothing
ElseIf cell.Value Like "?*#?*.?*" Then
sImage = IMG_NAME & rngImage.Row & ".jpg" ' unique image name for each email
jpgFilename = CopyRangeToJPG(rngImage, sImage)
' email body
html = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/><br/>" _
& ws.Range("B15") & " " & ws.Range("C15") & " " & ws.Range("D15") & _
"<p>" & ws.Range("B16") & "</p><br/>" & _
"<img src=""cid:" & sImage & """ width=550 height=150>" & _
"<br/>" & ws.Range("B17")
If TEST Then
MsgBox "Image: " & jpgFilename & vbLf & html, vbInformation, "To: " & cell.Value
'Debug.Print html
Else
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add jpgFilename, 1, 0
.HTMLBody = html & .HTMLBody
' add attachments
For Each cellA In rngA.SpecialCells(xlCellTypeConstants)
filename = Trim(cellA.Value)
If filename <> "" Then
If Dir(filename) <> "" Then ' check file exists
.Attachments.Add filename
Else
MsgBox "Could not attach : " & filename, vbExclamation, cell.Value
End If
End If
Next
End With
Set OutMail = Nothing
End If
' next image
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
n = n + 1
End If
Next
Set OutApp = Nothing
MsgBox n & " emails sent", vbInformation
End Sub
Function CopyRangeToJPG(rngImage As Range, filename As String) As String
Dim ws As Worksheet, folder As String
Set ws = rngImage.Parent ' sheet
' check range
If rngImage Is Nothing Then
MsgBox "Sorry this is not a correct range"
CopyRangeToJPG = ""
Exit Function
End If
' create image file
folder = Environ$("temp") & Application.PathSeparator
rngImage.CopyPicture
With ws.ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height)
.Activate
.Chart.Paste
.Chart.Export folder & filename, "JPG"
End With
ws.ChartObjects(ws.ChartObjects.Count).Delete
' return status
CopyRangeToJPG = folder & filename
End Function

Sending email with body of message being the contents of a cell, including new-line formatting?

I'm trying to send an email with the body of the message consisting of the contents of a text box. So far I've tried pulling in the text box through vba as a string, but that takes away all the new-lines formatting. Is there a way to get the text box contents exactly as they are into the email?
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim title As String, emailto As String
Dim texts As String
title = Range("email_subject").Value
emailto = Range("email_to").Value
texts = Worksheets("Input").Shapes("TextBox 2").TextFrame.Characters.Text
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emailto
.Subject = title
.HTMLBody = texts
.display
End With
On Error GoTo 0
End Sub
Please find an example below that might help with your question. You will have global variable that will hold information from excel worksheet and use them in the email. Whithout a image on how your data looks cannot really guess what you are trying to do. Maybe you can separete the text in different cells that way you can loop throught and put them in different variables and you can construct your email in the SendEmail procedure. Or if you have the same text and it doesn't change you can make it as per the below example.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Problem Attaching Excel File to Email with VBA

I'm attempting to add attach a file to an email created from a template. The idea is to be able to use the File Picker to select multiple files and excel sends an email to the proper recipients with the correct attachments.
The problem is that I cannot use the ".Display" method without getting an error and I want to review the email before sending so I do not want to use ".Send".
However, for whatever reason, if I clear the email template body with ".Body = ''", I am able to Display the email and attach the correct file. I'd like to keep the email body from the template as is though without clearing it and rewriting it.
So it seems that I cannot use an email template if I want to first display before sending? Has anyone ever had this problem or know how to solve?
The Error message is:
'-2147221233(8004010f)' The attempted operation failed. An object could not be found.
Btw, most of the variables are declared globally so that is why they are not visible.
Dim Agency As String
Dim xfullName As Variant
Dim Template As String
Dim mail As Outlook.mailItem
Dim myOlApp As Outlook.Application
Dim selectedFile As Variant
Dim emailBody As String
Dim emailType As String
Dim recipients As String
Sub Recall_Email()
Dim fileName As String
Dim inputFile As FileDialog
Set myOlApp = CreateObject("Outlook.Application")
Set inputFile = Application.FileDialog(msoFileDialogFilePicker)
Template = "C:\Users\me\AppData\Roaming\Microsoft\Templates\Recall Templates\Recall Template.oft"
With inputFile
.AllowMultiSelect = True
If .Show = False Then Exit Sub
End With
For Each selectedFile In inputFile.SelectedItems
xfullName = selectedFile
fileName = Mid(inputFile.SelectedItems(1), InStrRev(inputFile.SelectedItems(1), "\") + 1, Len(inputFile.SelectedItems(1)))
Agency = Left(fileName, 3)
CreateTemplate(Template)
Next selectedFile
End Sub
Private Sub CreateTemplate(temp)
Set myOlApp = CreateObject("Outlook.Application")
Set mail = myOlApp.CreateItemFromTemplate(temp)
Set olAtt = mail.Attachments
With mail
'.Body = "" -- If I use this line, everything attaches
.Subject = Agency & " Recall File"
.To = "email"
.Attachments.Add xfullName
.Display '.Send
End With
End Sub
Here is a working example on how to attach or embed files to outlook.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Run same macro in different versions of Excel / Outlook / Word

I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

vba to automatically email select sheet in spreadsheet if condition is met

I am trying out a couple different ways to automatically email using VBA and having trouble with the 2 items listed below. The VB does run as is but I would like to try to incorporate these two items if possible. Thank you :).
only attach sheet2(attachment). The file is located in bold in the code below.
only send the attachment if comment 2 is checked (cell D2)
VB
Private Sub CommandButton1_Click()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
Dim MyFile As String
**MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"**
If Dir(MyFile) = "" Then
MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
GoTo Abort
End If
On Error Resume Next
Set obj = GetObject(, "Outlook.Application")
On Error GoTo 0
If obj Is Nothing Then
Set obj = CreateObject("Outlook.Application")
End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFile, 1
.Send
End With
MsgBox "The data has been emailed sucessfully.", vbInformation
Next c
Set OutMail = Nothing
Abort: Application.Quit
Set OutApp = Nothing
End Sub
Update
Dim MyFile As String, MyFileCopy As String
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Sheet2.xlsm"
' no need to look for MyFile because you are working within it ...
'MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"
' If Dir(MyFile) = "" Then
'
' MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
' GoTo Abort
'
' End If
'create a separate sheet2 to mail out
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
.SaveAs MyFileCopy
.Close True
End With
'this is not needed, since you set the outlook app below
' On Error Resume Next
' Set obj = GetObject(, "Outlook.Application")
' On Error GoTo 0
' If obj Is Nothing Then
' Set obj = CreateObject("Outlook.Application")
' End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
If c.Offset(, 3) = "x" Then 'Not sure how you have Comment2 "checked" in column D
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFileCopy, 1
.Send
End With
End If
Next c
MsgBox "The data has been emailed sucessfully.", vbInformation
Set OutMail = Nothing
Set OutApp = Nothing
Abort:
Application.Quit 'This will kill the Excel application, is this really what you want?
End Sub
See the below code. I placed a section to make a copy workbook with sheet2 to send as an attachment as well as added in the condition for D2 (assume column for each row) to check for the condition. See my comments, as I took some liberties without knowing how your exact data works. I also cleaned up some of the stuff that looked superfluous.
Private Sub CommandButton1_Click()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
Dim MyFile As String, MyFileCopy As String
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsm"
' no need to look for MyFile because you are working within it ...
'MyFile = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form.xlsm"
' If Dir(MyFile) = "" Then
'
' MsgBox "The file to attach was not found here:" & vbLf & vbLf & MyFile, vbExclamation, "Exiting"
' GoTo Abort
'
' End If
'create a separate sheet2 to mail out
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
.SaveAs MyFileCopy
.Close True
End With
'this is not needed, since you set the outlook app below
' On Error Resume Next
' Set obj = GetObject(, "Outlook.Application")
' On Error GoTo 0
' If obj Is Nothing Then
' Set obj = CreateObject("Outlook.Application")
' End If
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
Set Rng = WS.Range("A2", WS.Range("A" & Rows.Count).End(xlUp))
For Each c In Rng
If c.Offset(, 3) = "Checked" Then 'Not sure how you have Comment2 "checked" in column D
Msg = Msg & "For " & c.Offset(, 1) & Chr(14) & Chr(14)
For i = 3 To 14
If WS.Cells(c.Row, i) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c.Offset(, 0)
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
.Attachments.Add MyFileCopy, 1
.Send
End With
End If
Next c
MsgBox "The data has been emailed sucessfully.", vbInformation
Set OutMail = Nothing
Set OutApp = Nothing
Abort:
Application.Quit 'This will kill the Excel application, is this really what you want?
End Sub

Resources