I'm attempting to send an email containing an Excel workbook from within the document using the built in VB macros. There is data in one of the sheets, which are relevant to sending the email (Subject, recipient etc). I am trying to access these using the Sheets object like so
Sub Button1_Click()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim cell As Object
Dim count As Integer
count = 0
For Each cell In Selection
count = count + 1
Next cell
If count <> 1 Then
MsgBox ("You must select exactly one cell, which shall be the e-mail address of the recipient")
Wscript.Quit
Else
recipient = ActiveCell.Value
End If
On Error Resume Next
With OutMail
.To = recipient
.CC = ""
.BCC = ""
.SentOnBehalfOfName = This.Sheets("MailContent").Range("A2").Value
.Subject = This.Sheets("MailContent").Range("A4").Value
.Body = This.Sheets("MailContent").Range("A6").Value & vbNewLine & This.Sheets("MailContent").Range("A7") & vbNewLine & vbNewLine & "Næste gang senest den " + This.Sheets("MailContent").Range("A10") & vbNewLine & vbNewLine & This.Sheets("MailContent").Range("A8")
.Attachments.Add ActiveWorkbook.Name
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I've also been able to replicate the same error with this small snippet
Sub Button1_Click()
Dim subjectCell As Range
subjectCell = This.Sheets("MailContent").Range("A2")
MsgBox (subjectCell.Value)
End Sub
I've tried using WorkSheets, Sheets, ActiveWorkbook to access the cells, but I'm sure it's just a problem of how I assign the data, since I'm not used to languages with syntax like VB. Any help is much appreciated, and if you need more info leave me a comment.
You need to use the 'Set' keyword to assign to a range.
Set subjectCell = ThisWorkbook.Sheets("MailContent").Range("A2")
This still catches me out on an irritatingly regular basis.
Related
In my Excel File I have a CommandButton which sends an E-Mail if cells E1, K2 and K5 are filled.
Unfortunately my code does not really work.
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim nameList As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo cleanup
If Sheets("Sheetname").Range("E1").Value = "" Or _
Sheets("Sheetname").Range("K2").Value = "" Or _
Sheets("Sheetname").Range("K5").Value = "" Then
MsgBox "The Cells E1, K2 and K5 has to be filled!"
Else
MsgBox "All Cells are filled, send E-Mail now"
For i = 2 To 22
If Sheets("efforts and risks").Range("BB2").Value <> "" Then
nameList = nameList & ";" & Sheets("efforts and risks").Range("BB" & i).Value
End If
Next
With OutMail
.To = nameList
.Subject = "subject line"
.Body = "Body Text"
.Send
End With
End If
cleanup:
Set OutApp = Nothing
End Sub
If the cells are filled Excel shows the MsgBox, but it does not send the mail. Which part of my code do I have to change?
Hope someone can help me. Thanks a lot
I have an Excel table and a bit of macro. I wanted to automatically send email to a certain person when cell value == to "Yes". Also I want to send the email only if the date is today.
Please see screenshot:
Error Screenshot Sir
Private Sub cmdMove_Click()
'Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("J").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "H").Value) = "Yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ThisWorkbook.ActiveSheet("Server").Range("I3").Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "Ryan").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
End Sub
Try something like the following. Assumes Date is in column A and is an actual Date and that can be compared with what the Date function returns. There is a fair bit of tidying up that could be done on this.
I would take note of #BruceWayne's comment regarding using a Worksheet_Change event. If you can decide which cell(s), or column, determine(s) the triggering of the sub e.g. if column H has a value that changes then test each condition and determine whether to send e-mail, then you can call this sub via that event.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then 'e.g. for column H
TestFile 'name of your sub
End If
End Sub
Note I changed your LCase test as it could never be True with LCase = "Yes" and I used the typed function LCase$.
I have commented out the line for the body as this:
.Cells(cell.Row, "Ryan").Value
will throw an error. The "Ryan" part should be a column reference e.g. "A" or 1.
If the "Ryan" is a named range then you might use something like:
.Cells(cell.Row, .Range("Ryan").Column)
Code:
Option Explicit
Public Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
With ActiveSheet
For Each cell In .Columns("J").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase$(.Cells(cell.Row, "H")) = "yes" And .Cells(cell.Row, "A") = Date Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = wb.Worksheets("Server").Range("I3").Value
.Subject = "Reminder"
' .Body = "Dear " & .Cells(cell.Row, "Ryan").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
End With
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Example of Worksheet_Event code in Sheet2 code window
And the associated standard module:
I have to order reports on accounts daily and then send an email with all of the reports but it has to be formatted a certain way. I finally made an Excel macro to order the reports but I am trying to make the macro also email the reports. Here is what I have so far.
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim Email As String
Dim ws As Worksheet
Set ws = Worksheets("Data")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
K = 2
Do While ws.Cells(K, 1) <> ""
ws.Cells(K, 5) = "ACCT:" & ws.Cells(K, 1).Value
K = K + 1
Loop
Email = "Hello, <br><br>" & _
"The following reports were ordered today: <br><br>" & _
"<br> ws.Cells(2, 5) & _
'"<br> ACCT:" & ws.cells(1, 2) & _
"<br><br> Thank you." & _
"<br><br><br> <i> Please note Call if you have any questions </i>" & _
With OutMail
.to = "me#me.com"
.CC = ""
.BCC = ""
.Subject = "Statements Ordered"
.HTMLBody = Email
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
What I have it do is take the AC numbers that are in the book in column A and then match it with ACCT: so that cells E:E900 have ACCT: 12345.... but I dont know how to add that cell into the HTML body. Below it I have commented out a 2nd way I tried but also failed and that was to try and match the ACCT: & ws.Cells(1,2).
So Question: is there a way to either use an If then statement inside of the HTMLbody or is there a way to add the cell value inside the HTMLbody?
I have a workbook that has 7 worksheets. I have the below vba to send an email once a value is met on a particular sheet.
Each sheet has a different value and a different attachment to be sent. How do I add a code for each sheet so the email is sent?
Thanks in advance
Set as General (Declarations)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("M4:M368"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 3500 Then
Call Fuel_LevelW03
End If
End If
End Sub
followed by a module
General Fuel_LevelW03
Sub Fuel_LevelW03()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi" & vbNewLine & vbNewLine & _
"Please order fuel as attached." & vbNewLine & _
"" & vbNewLine & _
"Kind Regards" & vbNewLine & _
""
On Error Resume Next
With OutMail
.To = "email address"
.CC = "email address"
.BCC = ""
.Subject = "Fuel Order W03"
.Body = strbody
.Attachments.Add ("H:\Fuel Order Sheets\Glen Eden W03 Pump Station.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
From what I understand, you try to "tell the method" a bit about what the Target.Value was. Just pass the parameter to the function like this :
If IsNumeric(Target.Value) Then
If Target.Value < 3500 Then
Call Fuel_LevelW03( Sh.Name, Target.Value )
End If
End If
and change the function's name with this one :
Fuel_LevelW03( sheetName as String, targetValue as String )
'Change String to appropriate type
EDIT2 : I changed the code around a bit, if you need any help let me know.
EDIT : Ok, here's how you solve this. Inside the "ThisWorkbook" code object (underneath the sheet code objects, on the left side of the code editor), paste this :
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("M4:M368"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 3500 Then
Call Fuel_LevelW03( Sh.Name )
End If
End If
End Sub
Sub Fuel_LevelW03( sheetName as String )
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
If sheetName = "Sheet1" Then 'Replace Sheet1 with the name of your worksheet
strbody = "Hi" & vbNewLine & vbNewLine & _
"Please order fuel as attached." & vbNewLine & _
"" & vbNewLine & _
"Kind Regards" & vbNewLine & _
"STRING BODY1"
With OutMail
.To = "email address"
.CC = "email address"
.BCC = ""
.Subject = "Fuel Order W03"
.Body = strbody
.Attachments.Add ("H:\Fuel Order Sheets\Glen Eden W03 Pump Station.xlsx")
.Send
End With
On Error GoTo 0
ElseIf sheetName = "Sheet2" Then 'Replace Sheet2 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet2"
ElseIf sheetName = "Sheet3" Then 'Replace Sheet3 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet3"
ElseIf sheetName = "Sheet4" Then 'Replace Sheet4 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet4"
'ElseIf ............. (So on, so forth)
End If
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can add as many ElseIf's as you want (one for each sheet)
Am pretty sure this is what you need, although am not sure.
If ActiveSheet.Name = "Sheet1" Then
'Do something specific to "Sheet1"
ElseIf ActiveSheet.Name = "Sheet2" Then
'Do something specific to "Sheet2"
'And so on so forth...
End If
You have a button to that macro in each sheet, and depending on the sheet calling the macro, you want a different e-mail to be sent, right? Then this will do it. You can add as many ElseIf's as you want.
I am writing a macro to send an e-mail from an excel sheet. The macro prepares a few reports and then has a function to prepare the e-mail for the report. Everything works fine except when it gets to the .Send line it gives me a run time error -2147467259. Not sure what this means, but would appreciate the help.
Here is the code for the function:
Function Mail_Reports(ByRef wkDate2 As String, fileDate2 As String, wkNumber2 As String, thisYear2 As String)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Dim mailList As String
Dim i As Long, lstRow As Long, p As Long, addressNum As Long, begRow As Long
Dim proNam2 As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next
' Change the mail address and subject in the macro before you run it.
For i = 1 To 5 Step 1
mailList = ""
lstRow = Sheets("Data").Cells(Rows.Count, i).End(xlUp).Row
addressNum = lstRow - 16
begRow = lstRow - addressNum
proNam2 = Sheets("Data").Cells(16, i)
proNam2 = Replace(proNam2, " ", "")
For p = 1 To addressNum Step 1
mailList = Sheets("Data").Cells(begRow + p, i) & " ; " & mailList
Next p
With OutMail
.To = mailList
'.CC = "" remove comma and use this if you want to cc anyone, can be string or variable
'.BCC = "" remove comma and use this if you want to cc anyone, can be string or variable
.Subject = "Test"
.HTMLBody = "<HTML><BODY><Font Face=Calibri(Body)><p>Hi All,</p><p2>Attached to this e-mail is the test file.<p2/><br><br><p3>Best,<p3/></font></BODY></HTML>"
.attachments.Remove 1
.attachments.Add "C:\Documents and Settings\test.xlsx"
.Display
.Send
Next i
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Function
Can you please try with just,
Save the report file into a local drive
use one email address first, so remove the for loop
send it with just one file/range/workbook.
remove html tags for signature or etc..
Code:
With WB '-- workbook
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "myname#myname.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Here is a Report on My VBA analysis"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\testmail.txt") '-- .xls
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Update based on the comments with OP:
Looking at your email concat loop, you do not have to do it each time when a new book comes UNLESS YOUR MAILING LIST DIFFERS FOR EACH WORKBOOK.... You may take that loop out of the mail workbooks iteration.
For p = 1 To addressNum Step 1
mailList = Sheets("Data").Cells(begRow + p, i) & " ; " & mailList
Next p
One problem I can see here is that you do the following:
Set OutMail = OutApp.CreateItem(0)
outside the send loop. You should move that here:
[...]
For p = 1 To addressNum Step 1
mailList = Sheets("Data").Cells(begRow + p, i) & " ; " & mailList
Next p
Set OutMail = OutApp.CreateItem(0)
With OutMail
[...]
I can't comment on your specific error because I don't know what data is going into your OutMail object. However, to help you debug, I recommend you:
Close the With OutMail block with an End With
Set a reference to Microsoft Outlook 14.0 Object Library
Declare OutApp as Outlook.Application (Dim OutApp as Outlook.Application)
Declare OutMail as Outlook.MailItem (Dim OutMail as Outlook.MailItem)
Initialise OutApp as follows: Set OutApp = New Outlook.Application
The above are not necessary (except maybe closing your With OutMail block) but may help you to diagnose problems with your code.
Also note that if you're using a newer version of Outlook, other applications (Excel, Word, Access etc.) may be prevented from sending by security controls: http://support.microsoft.com/kb/263084.