Currently I have a sheet that sends a email to a specific email address, on this sheet there is a specific validation list with two options. If I select one option it will send an email to the email specified. However if I select the second option nothing happens. And there is no error.
I would like to be able to send the sheet two different email address depending on what has been selected within the list, and press click on the send button.
Code:
Private Sub CommandButton1_Click()
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' 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
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.
With OutMail
.To = "JABAAR.ALI# "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
Else
If Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End If
End Sub
I just figured out why it was fundamentally not working. You need to declare and set your objects inside both branches of the IF. The way it's setup right now, you declare them in the top block, but not the bottom one.
You need to have those lines in the Else part as well :
dim OutApp as object
Set OutApp = CreateObject("Outlook.Application")
dim OutMail as object
set OutMail = OutApp.CreateItem(0)
Try this code out :
Private Sub CommandButton1_Click()
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' 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
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.
With OutMail
.To = "JABAAR.ALI# "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
ElseIf Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End Sub
I have initialised the Outlook variables toward outside the If statement and it now seems to work.
Private Sub CommandButton1_Click()
dim OutApp as object
Set OutApp = CreateObject("Outlook.Application")
dim OutMail as object
set OutMail = OutApp.CreateItem(0)
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' 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
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.
With OutMail
.To = "JABAAR#"
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
ElseIf Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End Sub
Related
Very closely related to Embed picture in outlook mail body excel vba
I'm trying to embed an image into an Outlook email.
I'm using the following code snippet, half of which has been stolen from the post above:
Sub PictureEmail()
Dim outApp As New Outlook.Application
Dim OutMail As Object
Dim Attchmnt As String
Dim Signature As String
Dim WB As Workbook
Set WB = ThisWorkbook
Attchmnt = "C:\Users\Blah\Painted_Lady_Migration.jpg"
Set OutMail = outApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = WB.Names("to").RefersToRange.Value2
.CC = WB.Names("cc").RefersToRange.Value2
.BCC = WB.Names("bcc").RefersToRange.Value2
.Subject = WB.Names("Subject").RefersToRange.Value2
.HTMLBody = "<img src=""cid:Painted_Lady_Migration.jpg""height=520 width=750>"
.display
End With
If Attchmnt = "" Then
Else
OutMail.Attachments.Add Attchmnt
End If
On Error GoTo 0
End Sub
However, when looking at the generated email, I have the error "The linked image cannot be displayed. The file may have been moved, renamed, or deleted".
I've tried a few different ways to attach the file, including:
.HTMLBody = "<img src=" & Chr(34) & "cid:Painted_Lady_Migration.jpg" & Chr(34) & "height=520 width=750>"
I just can't get it to work >_<
I saw somewhere that spaces in the name/filepath can throw it, so I replaced the spaces in the name with underscores
What dumb thing am I forgetting/missing?
The cid is created when you attach it, so you need to do that before you display/send it.
Try it like this
Set OutMail = outApp.CreateItem(0)
With OutMail
.To = WB.Names("to").RefersToRange.Value2
.CC = WB.Names("cc").RefersToRange.Value2
.BCC = WB.Names("bcc").RefersToRange.Value2
.Subject = WB.Names("Subject").RefersToRange.Value2
If Attchmnt <> "" Then
.Attachments.Add Attchmnt ' (additional arguments are optional)
.HTMLBody = "<img src=""cid:Painted_Lady_Migration.jpg"" height=520 width=750>"
Else
.HTMLBody = "[no attachment included]"
End If
.Display
End With
I am trying to attach a file to outlook using VBA, however my code always seems to attach a blank file.
The code currently saves a workbook in a pre-defined path and then adds a file by the same name as an attachment to outlook but the file attached is blank and I'm not sure why. This "blank" file does not appear to be saved anywhere by the code so not sure where it is coming from.
Dim NewWkb As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim COB As Variant
COB = Range("B16").Value
COB = Format(COB, "DD_MMM_YYYY")
Application.DisplayAlerts = False
Set NewWkb = Workbooks.Add
NewWkb.SaveAs "C:\Users\Documents\BS_Spray " & COB
For i = 2 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Sheets(i).Copy NewWkb.Worksheets(NewWkb.Worksheets.Count)
Next
Sheets("sheet1").Delete
Application.DisplayAlerts = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = " "
.Subject = "SL Utility B/S Report " & J
.Body = "Hi all," & vbNewLine & vbNewLine & "Please see attached " & J
.Attachments.Add NewWkb.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You should pass "C:\Users\Documents\BS_Spray " & COB to .Attachments.Add
We are publishing emails in which the body contains current week number. I have the vba code ready for the email (reference rondebruin) but I'm not able to get current week to populate in the email body.
Private Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
On Error GoTo errorhandler
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = ""
.CC = "" ''
.BCC = ""
.Subject = "Reports"
.HTMLBody = "Hello All," & "<br>" & "<br>" & "Reports for [week_nm] have been published and saved to the designated locations."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
To get the current week number of the year, use:
Application.WorksheetFunction.IsoWeekNum (Now())
In your code, alter the body line to something like..
.HTMLBody = "Hello All," & "<br>" & "<br>" & "Reports for week " & Application.WorksheetFunction.IsoWeekNum(Now()) & " have been published and saved to the designated locations."
I use this code to send email from Excel:
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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send ' <--------------------------------This is causing troubble
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The problem is that .Send is not recognized as an object (or method).
Other commands are working (i.e. Display, Save).
I believe this error exists because of security systems at my work. I have even tried using CDO and it is not working ether.
Change .Send to .Display and put SendKeys "^{ENTER}" before the With OutMail line.
Try this code.
Sub Email_ActiveSheet_As_PDF()
'Do not forget to change the email ID
'before running this code
Dim OutApp As Object
Dim OutMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = Environ$("temp") & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = StrToReceipent
.CC = StrCCReceipent
.BCC = StrBCCReceipent
.Subject = StrSubject
.Body = StrBody
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Send 'or use .Display to show you the email before sending it.
.Display
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder
Kill FileFullPath
'set nothing to the objects created
Set OutMail = Nothing
Set OutApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email has been Sent Successfully")
Exit Sub
err:
MsgBox err.Description
End Sub
I am trying to set up several buttons on an Excel form to email different groups of people.
I made several ranges of cells on a separate worksheet to list the email addresses.
For example, I want "Button A" to open Outlook and put the list of email addresses from "Worksheet B: Cells D3-D6". Then all that has to be done is hit "Send" in Outlook.
Sub Mail_workbook_Outlook_1()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
EmailTo = Worksheets("Selections").Range("D3:D6")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = EmailTo
.CC = "person1#email.com;person2#email.com"
.BCC = ""
.Subject = "RMA #" & Worksheets("RMA").Range("E1")
.Body = "Attached to this email is RMA #" & Worksheets("RMA").Range("E1") & ". Please follow the instructions for your department included in this form."
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error Goto 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have to loop through every cell in the range "D3:D6" and construct your To string. Simply assigning it to a variant will not solve the purpose. EmailTo becomes an array if you assign the range directly to it. You can do this as well but then you will have to loop through the array to create your To string
CODE
Option Explicit
Sub Mail_workbook_Outlook_1()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Dim emailRng As Range, cl As Range
Dim sTo As String
Set emailRng = Worksheets("Selections").Range("D3:D6")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.CC = "person1#email.com;person2#email.com"
.BCC = ""
.Subject = "RMA #" & Worksheets("RMA").Range("E1")
.Body = "Attached to this email is RMA #" & _
Worksheets("RMA").Range("E1") & _
". Please follow the instructions for your department included in this form."
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
ToAddress = "test#test.com"
ToAddress1 = "test1#test.com"
ToAddress2 = "test#test.com"
MessageSubject = "It works!."
Set ol = CreateObject("Outlook.Application")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.RecipIents.Add(ToAddress)
newMail.RecipIents.Add(ToAddress1)
newMail.RecipIents.Add(ToAddress2)
newMail.Send
Both answers are correct.
If you user .TO -method then the semicolumn is OK - but not for the addrecipients-method. There you need to split, e.g. :
Dim Splitter() As String
Splitter = Split(AddrMail, ";")
For Each Dest In Splitter
.Recipients.Add (Trim(Dest))
Next