"Send Email" macro to multiple addresses

L

LKP

I am trying to get a send email button to send emails to multiple addresses.
I can get it to work for one address, but I don't know how to do multiples.
Here's the code:

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

With wb2
On Error Resume Next
.SendMail "(e-mail address removed)", _
"Product"
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file
Kill TempFilePath & TempFileName & FileExtStr

With Application
.ScreenUpdating = True
.EnableEvents = True

Can anyone help?

Also, when I click on this button, a security warning pops up asking if I
want to enable the macros, which I do. How do I turn that pop up off?
 
R

Ron de Bruin

Oops
Also, when I click on this button, a security warning pops up asking if I
Click to expand...

You can change the security

Use the shortcut to go to that dialog

Alt tms
 
L

LKP

Thanks, Ron. Do you know how I can make a mcaro button conditional? I want
this "Send Email" button to one person if certain conditions are met and
another person if these conditions are not met.
 
R

Ron de Bruin

You can use code like this in the macro to test a cell value


Dim ToStr As String

If LCase(Range("A1").Value) = "yes" Then
ToStr = "(e-mail address removed)"
Else
ToStr = "(e-mail address removed)"
End If

With wb2
On Error Resume Next
.SendMail ToStr, _
"Product"
On Error GoTo 0
.Close SaveChanges:=False
End With
 
L

LKP

Great, Ron. I think that will work. The variable I am looking for is if a
cell says "Exceeds a Threshold". How would I put this into the code? Also,
if I need to send to multiple addresses, can I use the array feature you
showed me earlier?

Thanks
 
R

Ron de Bruin

Try this

With wb2
On Error Resume Next
If LCase(Range("A1").Value) = "exceeds a threshold" Then
.SendMail Array("(e-mail address removed)", "(e-mail address removed)"), _
"This is the Subject line"
Else
.SendMail Array("(e-mail address removed)", "(e-mail address removed)"), _
"This is the Subject line"
End If
On Error GoTo 0
.Close SaveChanges:=False
End With
 
L

LKP

Sorry. I have another question. Is there a way to make the email screen
appear when someone hits the macro button so they can write a message instead
of just automatically sending the email?
 
L

LKP

Hi Ron-

The code I have is not working. Here is what I did: Any suggestions?
Thanks!

Private Sub CommandButton1_Click()
'Working in 2000-2007
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object

Set wb1 = ActiveWorkbook

If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no
VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro
again.", vbInformation
Exit Sub
End If
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) -
InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
If LCase(Range("C110").Value) = "exceeds a threshold" Then
.DisplayMail Array("(e-mail address removed)",
"(e-mail address removed)"), _
"CareTracker Pricing"
Else
.DisplayMail Array("(e-mail address removed)"), _
"CareTracker Pricing"
End With
On Error GoTo 0
wb2.Close SaveChanges:=False



'Delete the file
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
R

Ron de Bruin

Use it like this

Sub test()
'Working in 2000-2007
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object

Set wb1 = ActiveWorkbook

If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
If LCase(Range("C110").Value) = "exceeds a threshold" Then
.To = "(e-mail address removed);[email protected]"
Else
.To = "(e-mail address removed)"
End If
.CC = ""
.BCC = ""
.Subject = "CareTracker Pricing"
.Body = "Hi there"
.Attachments.Add wb2.FullName
.Display
End With
On Error GoTo 0

wb2.Close SaveChanges:=False

'Delete the file
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
L

LKP

Great! It works perfectly. Thanks again!

Ron de Bruin said:
Use it like this

Sub test()
'Working in 2000-2007
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object

Set wb1 = ActiveWorkbook

If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
If LCase(Range("C110").Value) = "exceeds a threshold" Then
.To = "(e-mail address removed);[email protected]"
Else
.To = "(e-mail address removed)"
End If
.CC = ""
.BCC = ""
.Subject = "CareTracker Pricing"
.Body = "Hi there"
.Attachments.Add wb2.FullName
.Display
End With
On Error GoTo 0

wb2.Close SaveChanges:=False

'Delete the file
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Run-time error '1004'??? 6
email via userfrom? 5
command Button 2
Runtime error 1004 - cannot open the file 1
Send Mail in Excel Spreadsheet with fields in spreadsheet 3
Excel 2007 and VBA 12
file extension shows up twice on attachment 2
Address Range in Email Script 4

Top