Send Multiple Emails Via VBA

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