Sending Email Based on Cell Value within a Loop - excel

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

Related

How to prevent email from sending without attachment

I put in the on error resume next to continue if it cant find an email but now if it cant find an attachment it'll still send where as I need it to not send without an attachment and still continue if no email
Sub CreateStatement()
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
'Dim EApp As Outlook.Application
'Set EApp = New Outlook.Application
'Dim EItem As Outlook.MailItem
'Set EItem = EApp.CreateItem(olMailItem)
Dim path As String
path = "K:\E-Fax Invoicing\PDF Output\"
Dim RList As Range
Set RList = Range("A2", Range("a2").End(xlDown))
Dim R As Range
For Each R In RList
Set EItem = EApp.CreateItem(0)
With EItem
On Error Resume Next
.SentOnBehalfOfName = ""
.To = R.Offset(0, 2)
.Subject = "December Statement: "
.Attachments.Add (path & R.Offset(0, 3))
.Body = "Dear " & R & vbNewLine & vbNewLine _
& "Please find your " & R.Offset(0, 4) & " attached."
On Error GoTo 0
If .Attachments.Count > 0 Then
.send
Else
next
End If
End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub
You can check to see if the file exists before trying to add it as an attachment:
Sub CreateStatement()
Const PATH = "K:\E-Fax Invoicing\PDF Output\" 'use const for fixed values
Dim EApp As Object, EItem As Object, RList As Range, R As Range
Set EApp = CreateObject("Outlook.Application")
Set RList = Range("A2", Range("a2").End(xlDown))
For Each R In RList.Cells
f = Dir(PATH & R.Offset(0, 3).Value) 'any matching file?
Set EItem = EApp.CreateItem(0)
With EItem
.SentOnBehalfOfName = ""
.To = R.Offset(0, 2)
.Subject = "December Statement:"
.Body = "Dear " & R.Value & vbNewLine & vbNewLine _
& "Please find your " & R.Offset(0, 4).Value & " attached."
If Len(f) > 0 Then
.Attachments.Add PATH & f
.send
Else
.display
End If
End With
Next R
End Sub

Excel - Run-time error 13 in vba macro created

I am trying to create a macro to send automated reminders.
I am sending below the two macros:
Sub Auto_Open()
Dim vResp As Variant, dTime As Date
vResp = MsgBox("Inviare email ora?", vbYesNo)
If vResp = 6 Then 'YES
Call EmailReminder
ElseIf vResp = 7 Then 'NO
dTime = CDate(InputBox("Send email at:", , Time + TimeValue("00:00:10")))
Do Until Time = dTime 'OR = #8:00:00 AM#
DoEvents
Loop
Call EmailReminder
End If
End Sub
Sub EmailReminder()
Dim oOL As Outlook.Application, oMail As Outlook.MailItem, oNS As Outlook.Namespace
Dim oMapi As Outlook.MAPIFolder, oExpl As Outlook.Explorer
Dim sBody As String, dDate As Date
Dim oWS As Worksheet, r As Long, i As Long, sStart As String
Set oWS = Foglio1
Set oOL = New Outlook.Application
Set oExpl = oOL.ActiveExplorer
If TypeName(oExpl) = "Nothing" Then
Set oNS = oOL.GetNamespace("MAPI")
Set oMapi = oNS.GetDefaultFolder(olFolderInbox)
Set oExpl = oMapi.GetExplorer
End If
With oWS.Range("E1")
r = .CurrentRegion.Rows.Count
For i = 1 To r
dDate = .Cells(i, 1)
sBody = "Oggi è il compleanno di" & .Cells(i, 2) & dDate & .Cells(i, -4) & " " & .Cells(i, -3) & vbCrLf & "Facciamo i nostri auguri!"
If Date = dDate Or Date = Int(dDate) Then ' Use INT to eliminate time info
Set oMail = oOL.CreateItem(oIMailItem)
With oMail
.Recipients.Add "umberto.roselli#openfiber.it" 'Indirizzo ricevente
.Subject = "Nuovo compleanno oggi:" & .Cells(i, -4) & " " & .Cells(i, -3) & .Body = sBody: .Send
End With
End If
Next i
End With
MsgBox "Messaggio email inviato correttamente!"
End Sub
I keep getting, however, on the second macro the error Run-Time 13: Type not matching but it doesn't give me any indication where the error is.
Can you help me out?
Thank you very much in advance
Fyi
Private Sub Workbook_Open()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For i = 2 To Range("e65536").End(xlUp).Row
If Cells(i, 8) <> "Y" Then
If Cells(i, 5) - 7 < Date Then
strto = Cells(i, 7).Value 'email address
strsub = Cells(i, 1).Value & " " & Cells(i, 2).Value & " compleanno il " & Cells(i, 5).Value 'email subject
strbody = "Il compleanno di " & Cells(i, 1).Value & " " & Cells(i, 2).Value & " sarà il " & Cells(i, 5).Value & vbNewLine 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Send
End With
Cells(i, 8) = "Mail Sent " & Now()
Cells(i, 9) = "Y"
End If
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Can I add a file path from a cell in Attachments.Add?

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

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

While pasting data into an Outlook mail body - I get error 4506 "application locked for editing "

I have to compose a mail body that contains text from multiple sources .
However the line editor.Application.Selection.Paste gives an error "4505" application locked while editing
I paste multiple times from 3 sources to create many mails
Dim Outapp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim wd, cmmtrs, ftnt As Object
Dim editor As Object
Dim savePath As String
Dim filePath As String
Dim lastRow As Integer: lastRow = Sheet2.Range("D20000").End(xlUp).Row
filePath = Application.ActiveWorkbook.Path
savePath = filePath & "\" & Format(Now(), "yyyy-mm-dd")
Set wd = CreateObject("Word.Application")
Set cmmtrs = wd.Documents.Open(savePath & "\ABC.docx", ReadOnly:=True)
'create multiple emails
For i = 2 To lastRow
Set Outapp = CreateObject("Outlook.Application")
Set OutMail = Outapp.CreateItem(olMailItem)
Set vInspector = OutMail.GetInspector
Set editor = vInspector.WordEditor
With OutMail
.To = Sheet2.Range("B" & i).Value
.CC = Sheet2.Range("C" & i).Value
.Subject = Sheet2.Range("D" & i).Value
.Body = Sheet2.Range("E" & i).Value & vbCrLf & vbNewLine
Dim lst As Integer: lst = Sheet3.Cells(1000, Sheet3.Range("A3:XAA3").Find(i - 1).Column).End(xlUp).Row
Dim col1, col2 As Integer: col1 = Sheet3.Range("A3:XAA3").Find(i - 1).Column
.Display
End With
With OutMail
If Sheet3.Range("A3:XAA3").Find(i) Is Nothing Then
col2 = Sheet3.Cells.Find(What:="*", After:=Sheet3.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
Else
col2 = Sheet3.Range("A3:XAA3").Find(i).Column - 1
End If
Sheet3.Range(Sheet3.Cells(4, col1), Sheet3.Cells(lst + 1, col2)).Copy
editor.Application.Selection.Start = Len(.Body)
editor.Application.Selection.End = editor.Application.Selection.Start
Application.Wait (Now + 0.0001)
editor.Application.Selection.Paste
End With
If Sheet2.Range("G" & i) = "Yes" Then
cmmtrs.Content.Copy
With OutMail
editor.Application.Selection.Start = Len(.Body)
editor.Application.Selection.End = editor.Application.Selection.Start
Application.Wait (Now + 0.00005)
editor.Application.Selection.Paste
End With
End If

Resources