I'm trying to create an email for every row of data on my sheet.
It seems to be working until I add the .Attachments.Add line.
I am trying to identify the file path from a cell.
Sub CreateEmails()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Dim eBody As String
Range("A2").Select
Do Until IsEmpty(ActiveCell)
Set objEmail = objOutlook.CreateItem(olMailItem)
eBody = "<p>Hi " & ActiveCell(0, 1).Value & ", </p>" _
& "<p>Message Body</p>" & _
"<p>Thank you!</p><br>"
With objEmail
.to = ActiveCell(0, 2).Value
.Subject = ActiveCell(0, 3).Value
.HTMLBody = "<html><head></head><body>" & eBody & "</body></html>"
.Attachments.Add ActiveCell(0, 5).Value
.Display
End With
ActiveCell.Offset(1, 0).Select
Loop
End Sub
The Attachments.Add method requires the source of the attachment which can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment. It is not clear what value is passed in your sample code, so I'd suggest debugging the code more carefully and making sure a valid value is passed. For example:
Sub AddAttachment()
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myItem = Application.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add "C:\Test.doc", _
olByValue, 1, "Test"
myItem.Display
End Sub
Instead of using something like this,
ActiveCell(0,1).Value
you should use something like this.
ActiveCell.Offset(0,1).Value
Even better would be not to use ActiveCell, declare and use a variable for the range.
Sub CreateEmails()
Dim objOutlook As Object
Dim objEmail As Object
Dim rng As Range
Dim eBody As String
Set objOutlook = CreateObject("Outlook.Application")
Set rng = Range("A2")
Do Until rng.Value <> ""
Set objEmail = objOutlook.CreateItem(olMailItem)
eBody = "<p>Hi " & rng.Offset(0, 1).Value & ", </p>" _
& "<p>Message Body</p>" & _
"<p>Thank you!</p><br>"
With objEmail
.to = rng.Offset(0, 2).Value
.Subject = rng.Offset(0, 3).Value
.HTMLBody = "<html><head></head><body>" & eBody & "</body></html>"
.Attachments.Add rng.Offset(0, 5).Value
.Display
End With
Set rng = rng.Offset(1, 0)
Loop
End Sub
Related
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
I am trying to send an email with the below code from my workbook. It works fine but only until I try to attach a file.
The file is created by another VBA code and the file name is defined by the cell values specified below, but I get a debug error when I try to run the code and it won't attach. I've tested with a named path eg C:test\test.docx and it works fine.
How can I get it to accept the path based on the cell values? I've set it to .Display whilst testing rather than send.
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
You are using Cells(i, 4) on the path to the file before you defined what the variable i actually is! Maybe move the path inside your For Loop?
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
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
I have a sample sheet
I have a module that runs through the list in a loop within another loop, checking for duplicate names and then grouping the names together to send an email with an attachment based on Column D (Division).
Sample 4 would get one email with 3 attachments.
I have been asked to build in the ability to exclude people based on a value (I chose yes or no, column C) before running the module.
Reason being that if the list is long (over 1000 names) to set it before generating the emails. I would build in a trigger to set that value, but it is apparently an arbitrary decision made by the senders in a dept.
I have tried to build an IF statement into the loop as shown below but it is as if the If statement is coming out as not being true (I stepped through).
Which means all the With Outmail objects will not work.
I was able to get it to work by using the if statement with a for/next setup on its own (no loops), but cannot get it to work with the loop, which is the more important piece.
Here is the main piece of code. The main loop and then the if statement to account for the yes or no values:
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
And here is the full sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
Set strName = rng.Cells(r, 1)
Set strDept = rng.Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = rng.Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = rng.Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
Loop
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = 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
Figured it out, here is the final sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
Debug.Print LCase(rng.Cells(r, 2))
If Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
ElseIf Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "no" Then GoTo ContinueLoop
End If
Set strName = Cells(r, 1)
Set strDept = Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
.display
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
.Display
ContinueLoop:
Loop
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = 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
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