Send Multiple Emails Via VBA - excel

Question

I wonder whether someone could help me please.
I'm trying to write a script which send multiple emails to addressees on a spreadsheet, with various other pieces of information.
I've started to use a solution from Ron de Bruin (below).
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Splunk Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account: Production." & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select ‘Edit Account’." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This script works, but I then receive the 'Outlook' security ,message, which with over 100 recipients, isn't practical to keep pressing "Ok" to send the email.
So following more research I changed:
.send
to
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%"
But the problem I have is that the email is created, but isn't sent. Again not practical to keep pressing "Send" for over 100 users.
I then tried a CDO solution, but I ran into problems with the SMTP address because I'm using my works Microsoft Exchange which I'm not an administrator for, and so don't have any of the SMTP details.
I just wondered whether someone may be able to look a this please, and offer some guidance on how I can create the macro to run automatically.
Many thanks and kind regards
Chris

Answer 1

All,
I managed to get this working with the following:
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account for you" & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: https://right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
' .send
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Application.SendKeys "+o"
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I found through further testing, that a automatic pop up appeared when the 'Send' button was clicked by this command Application.SendKeys "%s", so I added Application.SendKeys "+o2, to automatically click "OK".
Kind regards
Chris

Answer 2

try
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
this is of course using .Send
make sure to turn them back on at end of sub