"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 "[email protected]", _
"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 = "[email protected]"
Else
ToStr = "[email protected]"
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
 
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("[email protected]",
"[email protected]"), _
"CareTracker Pricing"
Else
.DisplayMail Array("[email protected]"), _
"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 = "[email protected];[email protected]"
Else
.To = "[email protected]"
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 = "[email protected];[email protected]"
Else
.To = "[email protected]"
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...
 
Top