I have this code that emails a range as a picture via outlook. The problem is that the recipients are getting the outlook error "The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location."
Anyone know how I can fix this?
Sub RectangleRoundedCorners1_Click()
ActiveSheet.Unprotect Password:="Mortgage1"
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = ActiveSheet.Range("C5:F17")
If xRg Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
ActiveSheet.Shapes("Rectangle: Rounded Corners 13").Visible = False
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>" _
'& "<br> "
StrBody = "<br />" & "<b><FONT SIZE = 5><font color=red>Rates are subject to change
without notice</b></FONT SIZE = 5></font color=red>"
With xOutMail
.Subject = "Bench Mark Rates" & " " & Date
.HTMLBody = xHTMLBody & StrBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = "mcerrato#hotmail.com
.cc = "mcerrato#loandepot.com"
.Display
End With
ActiveSheet.Shapes("Rectangle: Rounded Corners 13").Visible = True
ActiveSheet.Protect Password:="Mortgage1"
End Sub
Just try so switch this two lines
As is
.HTMLBody = xHTMLBody & StrBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
To be
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.HTMLBody = xHTMLBody & StrBody
Related
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
I generate an Outlook HTML formatted email to send to the email address designated by cell.
I attach multiple files located in the same folder as the workbook with the FileDialog box.
I would like the initial folder that comes up to be the location of the current workbook.
Private Sub CommandButton1_Click()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C14").Value
.Subject = Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " Tile Estimate"
.HTMLBody = Range("B14").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the" & Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
End Sub
Update, here is what I ended up using
Sub Email_1()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.Filters.Clear
xFileDlg.Filters.Add "pdf files", "*.pdf"
xFileDlg.AllowMultiSelect = True
xFileDlg.InitialFileName = ThisWorkbook.Path
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C13").Value
.Subject = Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " Tile Estimate"
.HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Range("B13").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the " & Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
I am creating an email using VBA in Excel. For the body of the email I am taking the value of a TextBox in the excel sheet. I have enabled multiple lines in the TextBox and have put text on the first line and have text on the line below, but when I generate the email, it takes both lines of text and puts them on the same line in the email.
I need to know how to keep the line breaks in the TextBox.
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.Display
.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "<p>Dear " & Cells(cell.Row, "A").Value & ",</p>" _
& "<br><br>" & ActiveSheet.TextBox1.Value & _
.HTMLBody
.Attachments.Add ("")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
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
Here is the TextBox1 properties
You can replace your newlines, vbNewLine, with HTML formatted line-breaks, <br>, like so:
With outMail
.display
.To = Cell.Value
.subject = "Reminder"
.HTMLBody = "<p>Dear " & Cells(Cell.row, "A").Value & ",</p>" _
& "<br><br>" & Replace(ActiveSheet.TextBox1.Value, vbNewLine, "<br>") & _
.HTMLBody
.Attachments.Add ("")
.display
End With
You can Split your string here to sperate lines
.HTMLBody = "<p>Dear " & Cells(cell.Row, "A").Value & ",</p>" _
& "<br><br>" _
& Split(ActiveSheet.TextBox1.Value, ".")(0) &"." _
& "<br>" _
& Split(ActiveSheet.TextBox1.Value, ".")(1) & "." _
& .HTMLBody
The below code runs a macro and creates the jpeg.
How can I change the name of the sheet (ex:"Strategic") for an active sheet. When I copy a sheet the code don't work anymore, because of the reference name.
With OutMail
.SentOnBehalfOfName = "Me#Me.Com"
.Display
.Subject = "Strategic Sales"
.To = "Me#Me.Com"
> Call createJpg("Strategic", "A1:F11", "Quota") '
It's about a code to create an outlook mail objectand embed images
Sub sendMail()
Application.Calculation = xlManual
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim TempFilePath As String
'Create a new Microsoft Outlook session
Set appOutlook = CreateObject("outlook.application")
'create a new message
Set Message = appOutlook.CreateItem(olMailItem)
With Message
.Subject = "My mail auto Object"
.HTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello,<br ><br >The weekly dashboard is available " _
& "<br>Find below an overview :<BR>"
'first we create the image as a JPG file
**Call createJpg("Dashboard", "B8:H9", "DashboardFile")**
'we attached the embedded image with a Position at 0 (makes the attachment hidden)
TempFilePath = Environ$("temp") & "\"
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0
'Then we add an html <img src=''> link to this image
'Note than you can customize width and height - not mandatory
.HTMLBody = .HTMLBody & "<br><B>WEEKLY REPPORT:</B><br>" _
& "<img src='cid:DashboardFile.jpg'" & "width='814' height='33'><br>" _
& "<br>Best Regards,<br>Ed</font></span>"
.To = "contact1#email.com; contact2#email.com"
.Cc = "contact3#email.com"
.Display
'.Send
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.Calculation = xlCalculationAutomatic
End Sub
You need to create createJpg function which transform a range into a jpg file.
Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
ThisWorkbook.Activate
Worksheets(Namesheet).Activate
Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
Plage.CopyPicture
With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left,
Plage.Top, Plage.Width, Plage.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
Set Plage = Nothing
End Sub
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