I want to send automatic email from Excel though Outlook subject to the condition that the value in a column is greater than 2, and retrieve specific cells from the same row in which the conditions is true.
Furthermore, how can I send it to an email address saved in one of the cells within that row?
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("D7:D1000"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 2 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = "Email Address"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
With xOutMail
.To = Cells(xRg.Row,"A") ' column A
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Display 'or use .Send
End With
Related
I have some vba code, which I have attached to a excel button. When pressing the button the outlook mail box will appear- ready to send the mail. But for some reason the workbook is not attached to the mail. In the code below - I think something is wrong with add.attachments. at the end
My VBA code is:
Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("D7"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 200 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = "Email Address"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Attachments.Add "W\Desktop\Files\Workbook1
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
The following line of code is not complete:
.Attachments.Add "W\Desktop\Files\Workbook1
The Add method of the Attachments class creates a new attachment in the Attachments collection. The source of the attachment can be a file (represented by the full file system path with a file name), for example:
.Attachments.Add "C:\Test.xslx", olByValue, 1, "Test"
I'd also suggest specifying a local file path.
So my code loops through a range of cells and triggers an email on the condition that, in this example, N150 = F150. This works, the email is sent. But what I'm finding difficult is referencing the changed cell in the email body. You can see within the xMailBody variable I have tried cll.Offset(0, -12) so when N150 = F150 I am given the cell value 12 columns to the left which should be B150. Instead I am getting the value of B145 which is correct in that it's the right column but obviously the incorrect row. My target range is N145:N160 so I think it's only referecing the first row in my range. Any help would be greatly appreciated been trying to figure this out for days!
Dim target As Range
Dim cll As Range
Private Sub Worksheet_Calculate()
Set target = Range("N145:N160")
For Each cll In target
If (Range("N150") = Range("F150"))
Call Mail_small_Text_Outlook(target)
Exit For
End If
Next
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
cll.Offset(0, -12) & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
You are looping from N145:N160 but only checking if Range("N150") = Range("F150"). If that check is true it will be true on the first iteration when cll is N145 so the email is sent and the loop exits so no other cll is processed.
...
Set target = Range("N145:N160")
For Each cll In target
If cll = cll.offset(0, -12) then
'cll is public, no need to pass it or target across
Mail_small_Text_Outlook
Exit For
End If
Next
...
Instead of using a global variable, pass the value you want in the email as a parameter for your Mail_small_Text_Outlook function.
Dim target As Range
Private Sub Worksheet_Calculate()
Dim FoundCell as String
Set target = Range("N145:N160")
For Each cll In target
If (Range("N150") = Range("F150"))
FoundCell = Cstr(cll.Offset(0, -12).Value2)
Call Mail_small_Text_Outlook(FoundCell)
Exit For
End If
Next
End Sub
Sub Mail_small_Text_Outlook(FoundCell as String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
FoundCell & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Now you can watch the value of FoundCell prior to passing it into the function, making your debugging process far easier.
I have a simple code to open Microsoft Outlook and send an email with an attachment. I would like to send the email securely. Meaning, I would like to know if there is any code that would be tantamount to pressing the "Send Securely" button in outlook. Here is my code so far.....
Sub EmailInvoice()
Dim OutlookApp As Object, OutlookMessage As Object
Dim FileName As String, EmailAddress As String
EmailAddress = Range("ProviderEmail").Value
FileName = "C:\Users\rblahblahblah.txt"
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if
Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp =
CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
Exit Sub
End If
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
With OutlookMessage
.To = EmailAddress
.CC = ""
.BCC = ""
.Subject = "Invoice for Upload - " & Month
.Body = "Please upload the attached file to the Vendor Portal."
.Attachments.Add FileName
.Display
.Send
End With
End Sub
The code below will send it with a sensitivity enumeration but not securely (Certified Mail). I also add my signature (Default) to the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
For Each cell In ThisWorkbook.Sheets("Email List").Range("B1:B100")
If cell.Value Like "?*#?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.to = strto
.CC = ""
.BCC = ""
.Subject = ("*Confidential*: Policyholder Name Here - Policy # Here - Premium Bill")
.HTMLBody = "Attached is the most recent premium bill in Excel." & "<br><br>" & Signature
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Importance = 2 '(0=Low, 1=Normal, 2=High)
.Sensitivity = 3 '(0=Normal, 1=Personal, 2=Private, 3=Confidential)
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
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
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
I create a new email with the code below.
I'd like to have an attachment. I think I have to use an OutMail.Attachment.Method but the attachment needs to be a specific email.
I want the entire email with contents (ie. texts, files, pics, etc.) as the attachment.
I'd like to attach whatever email I have highlighted (as an .msg).
Public Sub RemarkRequest()
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
'Get the user signature
With OutMail
.Display
End With
Signature = OutMail.HTMLBody
'Change the mail address and subject in the macro before you run it.
With OutMail
.To = "yyy#bbb.com; zzz#bbb.com"
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = "Text" & Signature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Example will be -
'// Forces explicit declaration of all variables in a file
Option Explicit
Sub ForwardAsAttchment()
'// Declare variables
Dim olMsg As Outlook.MailItem
Dim olItem As Outlook.MailItem
Dim olSignature As String
On Error Resume Next
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No Item selected")
Exit Sub
End If
For Each olItem In Application.ActiveExplorer.Selection
Set olMsg = Application.CreateItem(olMailItem)
'// Get the user signature
With olMsg
.Display
End With
olSignature = olMsg.HTMLBody
'// Change the mail address and subject in the macro before you run it.
With olMsg
.Attachments.Add olItem, olEmbeddeditem ' Attch Selected email
.Subject = "Subject"
.To = "yyy#bbb.com; zzz#bbb.com"
.CC = ""
.BCC = ""
.HTMLBody = "Text" & olSignature
.Display
' .Send
End With
Next
'// Clean up
Set olItem = Nothing
Set olMsg = Nothing
End Sub