I have created this macro to send automatically mails via outlook! My macro runs but there is an issue. Instead of sending in the content of the mail only the value of the offset that I ask for, it sends the entire worksheet. I am providing the code below:
Dim ToArray As String
Dim CCArray As String
Dim Subject As String
Dim Content As String
Dim cell3 As Range
For Each cell3 In ws1.Range("D2:D" & lastrow1)
ToArray = cell3.Offset(0, 16).Value
CCArray = cell3.Offset(0, 17).Value
Subject = cell3.Offset(0, 18).Value
Content = cell3.Offset(0, 19).Value
ActiveWorkbook.EnvelopeVisible = True
With ws1.MailEnvelope
.Introduction = Content
.Item.To = ToArray
.Item.CC = CCArray
.Item.Subject = Subject
.Item.Send
End With
Application.DisplayAlerts = False
Next cell3
I think you should try to use that:
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Subject
.To = "email#address.com"
.cc = "email#address.com"
.BCC = "email#address.com"
.SentOnBehalfOfName = "email#address.com"
.HTMLBody = Content
.send
End With
Hope that helps...
Related
The below code is an auto email sender. It works only if there are attachments.
Some emails have 1 or more attachments. If the path is blank it will not work.
Each email has a variable number of attachments and some paths is empty. Is there any way to make the pdfadd1 to pdfadd5 ignore adding attachment if the path is empty?
Sub send_mass_email_display_only()
Dim i As Integer
Dim name As String, email As String, body As String, subject As String, copy As String, pdfadd1 As String, pdfadd2 As String, pdfadd3 As String, pdfadd4 As String, pdfadd5 As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
For i = 2 To 3
'Specific rows
name = Split(Cells(i, 1).Value, " ")(0)
'name = Cells(i, 1).Value
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
pdfadd1 = Cells(i, 5).Value
pdfadd2 = Cells(i, 6).Value
'pdfadd3 = Cells(i, 7).Value
'pdfadd4 = Cells(i, 8).Value
'pdfadd5 = Cells(i, 9).Value
body = Replace(body, "C1", name)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = Cells(7, 17).Value
.To = email
.cc = copy
.subject = subject
.body = body
.Attachments.Add (pdfadd1)
.Attachments.Add (pdfadd2)
'.Attachments.Add (pdfadd3)
'.Attachments.Add (pdfadd4)
'.Attachments.Add (pdfadd5)
.display
'.Send
End With
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
Next i
Set OutMail = Nothing
Set OutApp = Nothing
'MsgBox "Email(s) Sent!"
End Sub
Here is the relevant part. I just added an If statement to each one to make sure the length is greater than zero.
.body = body
If Len(pdfadd1) > 0 Then .Attachments.Add pdfadd1
If Len(pdfadd2) > 0 Then .Attachments.Add pdfadd2
If Len(pdfadd3) > 0 Then .Attachments.Add pdfadd3
If Len(pdfadd4) > 0 Then .Attachments.Add pdfadd4
If Len(pdfadd5) > 0 Then .Attachments.Add pdfadd5
.display
Also, you do not need the parenthesis around the argument for .Add in this case as it's not returning anything.
I have this code that I have cobbled together but, sadly I am stuck I can’t seem to work out how to only have the email addresses for overdue entries in the BCC.
I want it to create a single email to multiple email addresses from a list of emails that have a due date that is overdue and a previous email hasn't already been sent.
Sub Over_due()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim rng As Range
strbody = "Text goes here"
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 6) <> "Email Sent" Then
If Cells(lRow, 5) <= Date Then
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
For Each rng In Range("C:C")
If rng.Value Like "*#*" Then
If xEmailAddr = "" Then
xEmailAddr = rng.Value
Else
xEmailAddr = xEmailAddr & ";" & rng.Value
End If
End If
Next
On Error Resume Next
With xMailItem
.To = ""
.CC = ""
.BCC = xEmailAddr
.Subject = Range("A1").Value
.HTMLBody = strbody
'.Attachments.Add
.Display
End With
MsgBox "E-mail successfully created", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
Cells(lRow, 6) = "Sent email"
Cells(lRow, 7) = "" & Now()
End If
End If
Next
Set OutApp = Nothing
End Sub
I use a sub which automatically creates emails. and call it from various other subs - might come in handy:
Sub SendEmail(Optional ToAddresses As String, Optional CcAddresses As String, _
Optional BccAddresses As String, Optional Subject As String, _
Optional Body As String, Optional AttachFiles As Variant = False, Optional AutoSend As Boolean = False)
'RULES:
' Where there are multiple Addresses in ToAddresses, CCAddresses
' etc, they have to be separated by a semicolon
' AttachFiles should either be a string containing the full
' filename including the path, or (for multiple files) an array
' of same.
' Body can be HTML or just plain text.
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = ToAddresses
.CC = CcAddresses
.Bcc = BccAddresses
.Subject = Subject
If Body Like "*</*>*" Then
.HtmlBody = Body
Else
.Body = Body
End If
If Not AttachFiles = False Then
If IsArray(AttachFiles) Then
For x = LBound(AttachFiles) To UBound(AttachFiles)
.Attachments.Add (AttachFiles(x))
Next
Else
.Attachments.Add (AttachFiles)
End If
End If
If AutoSend = True Then
.Send
Else
.Display
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
It's not totally my code, I adapted it from here.
It won't completely solve your problem, but it might condense it down to something simpler and more like:
Sub OverDue()
Dim strBody as String
Dim Row as Long
Dim lLastRow as Long
StrBody = "Text here"
lLastRow = UsedRange.Rows.Count
For a = 2 to lLastRow
If Cells(a, 6) <> "Email Sent" And Cells(a, 5)<= Date Then 'This checks each row to see if that person needs an email
' DO STUFF HERE
' Either Call the other sub separately each time
' (which can allow for more personalised messages, like a mail merge),
' or add the person's email address to a string and call the sub
' after the loop.
Next
End Sub
Over to you to work out the rest of the details though!!
I fixed your code like that
Sub Over_due()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim rng As Range
Dim strbody As String
Dim xOutlook
Dim xMailItem
Dim xEmailAddr
strbody = "Text goes here"
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 6) <> "Email Sent" Then
If Cells(lRow, 5) <= Date Then
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
' For Each rng In Range("C:C")
' If rng.Value Like "*#*" Then
' If xEmailAddr = "" Then
' xEmailAddr = rng.Value
' Else
' xEmailAddr = xEmailAddr & ";" & rng.Value
' End If
' End If
' Next
'Do you really want to have all emails addresses in BCC because thats what you are doing
'I changed the above code to the following lines which will not take the complete column
Set rng = Range("C2:C" & lRow)
xEmailAddr = Join(WorksheetFunction.Transpose(rng), ",")
On Error Resume Next
With xMailItem
.To = ""
.CC = ""
.BCC = xEmailAddr
.Subject = Range("A1").Value
.HTMLBody = strbody
'.Attachments.Add
.Display
End With
MsgBox "E-mail successfully created", 64
Application.DisplayAlerts = False
' I changed that to Email Sent otherwise it will create the mai over and over again
Cells(lRow, 6) = "Email Sent"
Cells(lRow, 7) = "" & Now()
End If
End If
Next
Set OutApp = Nothing
End Sub
I'm working on a way to send emails to a list of recipients. All emails should contain the same body, but with unique attachments. The code I'm using successfully retrieves the addresses from column N, and inserts attachments based on paths in corresponding rows in columns O:AZ.
The issue I'm encountering is that the first email created using the code has no body. The recipient and attachments are correct, but the email itself is empty. All other emails created show the body correctly. I have very little experience with VBA, and cannot find what's causing the issue.
Any help regarding the code and possible issues would be appreciated! Please let me know if you need more details regarding the code or data.
Sub create_emails()
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 strobody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet2")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("N").Cells.SpecialCells(xlCellTypeConstants) 'email addresses located in Sheet2, column N
Set rng = sh.Cells(cell.Row, 1).Range("O1:AZ1") 'File paths stored in corresponding rows, columns 0:AZ
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
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
.Display 'Or use .Display / .Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You're setting strbody after you're using it, so the first time it's used it's empty.
Change:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
To:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
strbody = "Test text"
.Body = strbody
And also, if you had Option Explicit set, you'd notice that your declaration for strbody is mistyped to strobody.
I have got a workbook with 4 sheets:
1st - recipients email data such as TO, CC, Subject, from 2nd to 4th
the sheets which I need to send as an attachment to the recipients.
I made up the following script. But I faced 2 issues as a VBA beginner:
The 'loop' proposes for sending the 1st empty row from the 1st sheet
as well (I would like to stop with the last email details);
The 'ActiveWorkbook' sends all sheets (I would like to skip the 1st
one where the recipients & the VBA script are located);
I appreciate every advice/remark because I have been studying VBA for 3 months.
Thank you in advance!
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
End Sub
Have a look at this. This takes a copy of your workbook and saves it to the users "temp" location. It then does the modifications that you want to the copy of the workbook before attaching that.
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
Dim wb As Workbook, nwb As Workbook
Application.ScreenUpdating = False
Set wb = ThisWorkbook
wb.SaveCopyAs (Environ("temp") & "\temp_" & wb.Name)
Set nwb = Workbooks.Open(Environ("temp") & "\temp_" & wb.Name)
With nwb
Application.DisplayAlerts = False
' Delete relevant sheet
.Sheets(1).Delete
Application.DisplayAlerts = True
.Save
End With
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add nwb.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
nwb.Close
Application.ScreenUpdating = True
End Sub
Save a copy of your workbook
Open it
Remove the sheet from the copy
Save
Send this edited workbook
I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub