How can I embed a photo at the end of an email?
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)
On Error Resume Next
With OutMail
.Display
End With
signature = OutMail.body
With OutMail
.To = cell.Value
.CC = "xxxxx#gmail.com; xxxxxx#hotmail.com"
.Subject = "Hello"
.body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & _
vbNewLine & _
vbNewLine & _
"Body" & _
signature
sourcefile = "XXXXXXX"
sourcefile1 = "XXXXXX"
.Attachments.Add sourcefile
.Attachments.Add sourcefile1
.Send
End With
Set OMail = Nothing
Set OApp = Nothing
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The code works.
I would like to embed a Xmas image (JPEG). I have done a dig around the internet however am unable to figure it out what command function I can use to embed it.
You'll need to use the HTMLBody property of the email, as plain text wont let you embed an image.
You will also need to know the filename (not only path) of your image. An example of code that might work is:
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)
On Error Resume Next
With OutMail
.Display
End With
signature = OutMail.body
With OutMail
.To = cell.Value
.CC = "xxxxx#gmail.com; xxxxxx#hotmail.com"
.Subject = "Hello"
imgpath = "c:\XXXXXX\"
sourcefile = "XXXXXXX"
sourcefile1 = "XXXXXX"
.Attachments.Add imgpath & sourcefile
.Attachments.Add imgpath & sourcefile1
.HTMLBody = "<body><p>Dear " & Cells(cell.Row, "A").Value _
& "<br/>& _
"Body" & _
signature & _
"<IMG src=""""cid:""" & sourcefile & """ width=200></body>"
.Send
End With
Set OMail = Nothing
Set OApp = Nothing
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Related
I have a converted document from .docx into .pdf saved to the desktop. The last task is to attach this .pdf to the body of an e-mail; the HTML signature should remain unchanged.
I think the problem is this line of code and I don't know how to correct it:
.Attachments.Add PdfFile.FullName
The complete code:
Public Sub Mail()
Dim LastAuthor As String
LastAuthor = ActiveDocument.BuiltInDocumentProperties("last Author")
Dim Email As String
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.Signature = "HTMLbody"
.To = Email
.CC = ""
.BCC = ""
.Subject = ActiveDocument.Name
'.Body = "AVIZAT. Multumesc mult"
'.Attachments.Add ActiveDocument.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.HTMLbody = "AVIZAT, esantionul este in ordine. Multumesc" & "<br>" & .HTMLbody
Dim objDoc As Document
Set objDoc = ActiveDocument
objDoc.ExportAsFixedFormat _
OutputFileName:=Replace(objDoc.FullName, ".docx", ".pdf"), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile.FullName
'.Preview 'Preview the email must disable .send & MsgBox (or use .Send to send it)
.send
MsgBox "E-mail trimis cu succes"
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub
This will do:
Public Sub Mail()
Dim LastAuthor As String
Dim Email As String
Dim MyPdfName As String
Dim objDoc As Document
LastAuthor = ActiveDocument.BuiltinDocumentProperties("last Author")
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set objDoc = ActiveDocument
MyPdfName = Replace(objDoc.FullName, ".docx", ".pdf")
objDoc.ExportAsFixedFormat _
OutputFileName:=MyPdfName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = Email
.CC = ""
.BCC = ""
.Subject = objDoc.Name
.HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri>Servus<br>Esantionul este in ordine.<br><br>Multumesc,<br>" & .HTMLBody
.Attachments.Add MyPdfName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "E-mail trimis cu succes"
End Sub
It's far from perfect but is a lot clearer now and most importantly, works.
I am currently working on a macro that should create an email with variable recipients and details within the body of the email depending on input into the relevant row on the worksheet. It should generate an email per row where 'To do' is present in column P.
I currently have a sub coded with everything I think I need and when I run the macro no errors appear, unfortunately it does not open any template emails as intended either.
I'll admit that my VBA is basic at best but any assistance with the below would be great.
Sub Sendmail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim ClientEmail As Range
Dim PlannerName As String
Dim Salutation As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("F").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "Planner1 Initials" And _
LCase(Cells(cell.Row, "P").Value) = "To do" Then
Set ClientEmail = LCase(Cells(cell.Row, "H").Value)
PlannerName = "Planner1 Name"
Set Salutation = LCase(Cells(cell.Row, "D").Value)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Planner1#email.com"
.Subject = "Annual Review"
.Body = "send email to" & vbNewLine & vbNewLine & _
"Dear" & xClientSaluation & vbNewLine & vbNewLine & _
"body" & vbNewLine & _
"Best wishes" & vbNewLine & vbNewLine & _
"" & PlannerName
.Display
End With
ElseIf cell.Value = "Planner2 Initials" And _
LCase(Cells(cell.Row, "P").Value) = "To do" Then
Set ClientEmail = LCase(Cells(cell.Row, "H").Value)
PlannerName = "Planner2 Name"
Set Salutation = LCase(Cells(cell.Row, "D").Value)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Planner2#email.com"
.Subject = "Annual Review"
.Body = "send email to" & vbNewLine & vbNewLine & _
"Dear" & xClientSaluation & vbNewLine & vbNewLine & _
"body" & vbNewLine & _
"Best wishes" & vbNewLine & vbNewLine & _
"" & PlannerName
.Display
End With
ElseIf cell.Value = "Planner3 Initials" And _
LCase(Cells(cell.Row, "P").Value) = "To do" Then
Set ClientEmail = LCase(Cells(cell.Row, "H").Value)
PlannerName = "Planner3 Name"
Set Salutation = LCase(Cells(cell.Row, "D").Value)
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Planner3#email.com"
.Subject = "Annual Review"
.Body = "send email to" & vbNewLine & vbNewLine & _
"Dear" & xClientSaluation & vbNewLine & vbNewLine & _
"Body " & vbNewLine & _
"Best wishes" & vbNewLine & vbNewLine & _
"" & PlannerName
.Display
End With
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Appreciate that you likely don't need to repeat for each different set of initials as I have done above but was struggling to set a range without an object error.
The data held in the worksheet columns for context
F = Client Owner Initials
P = If an email needs to be sent, input either No, To Do, Yes or n/a
D = Client's salutation
Thanks,
BIG TWON
Thanks to Krib below, I am now getting Object required error on the following line, I imagine this will repeat throughout:
Set ClientEmail = LCase(Cells(cell.Row, "H").Value)
I think I can see three issues:
LCase(Cells(cell.Row, "P").Value) = "To do" Then
LCase will be seeing "to do", not "To do" so your main block(s) will never run.
Change them to:
LCase(Cells(cell.Row, "P").Value) = "to do" Then
Also, as per your recent update, the line:
Set ClientEmail = LCase(Cells(cell.Row, "H").Value)
Is trying to load the .Value of a cell into ClientEmail
Unfortunately, you have declared it a Range:
Dim ClientEmail As Range
From the looks of your code, you should be declaring it As String. But remember, you don't Set strings. You just load to them e.g:
ClientEmail = LCase(Cells(cell.Row, "H").Value)
Further to above point, you also do:
Dim Salutation As Range
and
Set Salutation = LCase(Cells(cell.Row, "D").Value)
Which should be:
Dim Salutation As String
and..
Salutation = LCase(Cells(cell.Row, "D").Value)
So to wrap up..
Your declarations should look like this:
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim ClientEmail As String
Dim PlannerName As String
Dim Salutation As String
Your IF statement(s) should look like this (change PlannerX each time):
If cell.Value = "Planner1 Initials" And LCase(Cells(cell.Row, "P").Value) = "to do" Then
And your variable settings should look like this (again, change PlannerX each time):
ClientEmail = LCase(Cells(cell.Row, "H").Value)
PlannerName = "Planner1 Name"
Salutation = LCase(Cells(cell.Row, "D").Value)
Maybe this will help you out...
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng 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")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
Got a macro running through columns with mail addresses using most parts from Ron de Bruin.
The macro runs through just fine, but only sends the first hit in column B and doesn't display any of the other hits when i try to watch it? What could be the issue?
The code is so that I can get the default signature from outlook, thats why it's .Display first in the code.
Sub mail_HTML()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
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
strbody = "<H3>Hei " & Cells(cell.Row, "E").Value & "</H3>" _
& "<p>" & Range("k4") & "<p>"
On Error Resume Next
With OutMail
.Display
.To = cell.Value
.Subject = Range("K12").Value
.HTMLBody = strbody & .HTMLBody
'You can add files also like this
'.Attachments.Add Range("O1").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
When you set
Set OutMail = Nothing
You dont have any access to the object anymore (because it is destroyed). But you set it before the loop. You need to set it in every loop then like this:
On Error Resume Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("K12").Value
.HTMLBody = strbody & .HTMLBody
'You can add files also like this
'.Attachments.Add Range("O1").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
So after 1 Email the oject is destroyed, but you are not aware because of the on error resume next
Tried that but it is not working for me, here is my code:
Do Until in_file.EOF
Email_To = in_file!email_address
Email_Bcc = ""
Email_Body = in_file!email_salut & " " & in_file!email_name & ", test this."
Email_Subject = "Email Subject"
Set mail_object = CreateObject("Outlook.Application")
Set mail_single = mail_object.CreateItem(0)
With mail_single
.Subject = Email_Subject
.To = Email_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.send
End With
Set mail_object = Nothing
Set mail_single = Nothing
in_file.MoveNext
Loop
Was working on a project which will be sending bulk mail to different people if the conditions are met.
Conditions :
Column U contains the final status (Open or WIP) (will not send if Closed no matter if current date is larger)
Column Q contains Closure date. Which when compared to current date, if less then automatic shooting mails to people.
I had tried to do with for loop but its giving shooting 4 mails with same To and CC. And not going to the next row to compare.
Thank you in advance.
Code as below:
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim x As Variant
Dim arr1 As Variant
Dim i As Long, r As Long
On Error Resume Next
arr1 = Worksheets("Data").Range("Q2:Q" & Range("Q" & Rows.Count).End(xlUp).row).Value
i = 1
For Each x In arr1
For r = 1 To 2
If x < Now() Then
If Sheets("Data").Worksheets("Data").Cells(i, "U").Value = "Open" Then
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
If Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Quality_Assurance" Then
StrBody = "Hi," & "<br>" & _
.To = "a"
.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then
StrBody = "Hi," & "<br>" & _
"PFB the process details which requires your attention." & "<br>" & _
"The review for this process has crossed over due." & "<br>" & _
"Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"
.To = "c"
.CC = "d"
.BCC = ""
.Subject = "Process Manual and Maps Review is Overdue"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
End If
End With
i = i + 1
Exit For
End If
End If
Next r
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next x
End Sub
Solved: This will solve the problem above.
Sub Data_RoundedRectangle1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
If Cells(i, 21).Value = "Open" And Cells(i, 17).Value <= Now() Then
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Data").Range("C1:V5").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Quality_Assurance" Then
StrBody = "Hi," & "<br>" & _
"PFB the process details which requires your attention." & "<br>" & _
"The review for this process has crossed overdue." & "<br>" & _
"Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"
.To = "a"
.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
ElseIf Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Analytics" Then
StrBody = "Hi," & "<br>" & _
"PFB the process details which requires your attention." & "<br>" & _
"The review for this process has crossed over due." & "<br>" & _
"Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"
.To = "c"
.CC = "s"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next i
End Sub
I wrote code that breaks up a report filled with providers into individual reports for each provider then saved them into a folder on my desktop to be emailed to the providers.
Now I'd like to add some code that would automatically email these providers for me but would let me take a look first before being sent. Here's my old code.
Sub VendorSeperate()
Application.DisplayAlerts = False
wb1 = ActiveWorkbook.Name
SaveFolder397 = Format(Now(), "mm.dd.yy hh mm ss AM/PM")
SaveFolder400 = "C:\Users\johndoe\Desktop\Test\" & SaveFolder397
On Error Resume Next
MkDir SaveFolder400
On Error GoTo 0
[A2].Select
ActiveWindow.FreezePanes = True
batchdate = Format(Cells(2, 1), "mm.dd.yy") & " Sent " & Format(Now(), "mm.dd.yy")
LR1 = Columns(1).Find("*", SearchDirection:=xlPrevious).Row
For I = 2 To LR1 + 2
If Cells(I, 1) = "" And Cells(I - 1, 1) <> "" Then
providername = Trim(Cells(I - 1, 7))
ActiveSheet.Copy
Cells.AutoFilter Field:=7, Criteria1:="<>*" & providername & "*", Operator:=xlAnd
Rows("2:" & LR1 + 100).SpecialCells(xlCellTypeVisible).Delete
Cells.AutoFilter
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWorkbook.SaveAs Filename:=SaveFolder400 & "\JD2.0 " & providername & " Ck Batch Date " & batchdate & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Workbooks(wb1).Activate
End If
Next I
End Sub
This is a really Simple Code to send an Email with Outlook. Maybe this can Help you.
Sub mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "abc#abc.ch"
.CC = ""
.BCC = ""
.Subject = "Subject line"
.Body = "Email text."
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub