Send emails with a five second interval

Question

I am trying to send emails with a five second interval.

I am using the Kernel32 Sleep function to insert a delay in my code. The problem is my email sending loop processes all the Sleep timers and then sends a batch of emails together.

I used the message box to confirm this. I think it might be because of multi threading but I am lost as how to make this an atomic function.

Here is a snippet of my code:

Public Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As LongPtr)

Sub Send_Emails()

Dim i As Integer
For i = 1 To 4
    Sleep (5000)

    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Set OutlookApp = New Outlook.Application
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)

    With OutlookMail

        .BodyFormat = olFormatHTML
        .HTMLBody = "Hi there," & .HTMLBody
        .To = "abc@gmail.com"
        .Subject = "Hello World"
        .Send

    End With

Next i

End Sub

Answer 1

You can use a timer to call a "send e-mail" function a finite number of times. This means you will be able to work in between messages as well whereas a wait or delay function will likely interfere with standard operation.

Please note: sending and receiving is asynchronous so unless a long delay is utilised, e-mails may be received out of order or non-representative of the timing between them.

For example:

Option Explicit

Private Declare Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Private Declare Function KillTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

'TimerIDs to turn off timers. If a TimerID <> 0 then the timer is running
Private SendTimerID As Long
Private SendCount As Long

Sub SendEmails()
    Call SendStartTimer
End Sub

Private Sub SendStartTimer()
    SendCount = 0
    Call SendEventFunction
    Call ActivateTimer(5, AddressOf SendEvent, SendTimerID)
End Sub

Private Sub SendEvent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
    On Error Resume Next
    Call SendEventFunction
    If SendCount = 4 Then DeactivateTimer SendTimerID
End Sub

Private Sub SendEventFunction()
    Dim OutlookApp As Outlook.Application: Set OutlookApp = New Outlook.Application
    Dim OutlookMail As Outlook.MailItem: Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    With OutlookMail
        .BodyFormat = olFormatHTML
        .HTMLBody = "Hi There," & .HTMLBody
        .To = "someone@somewhere.com"
        .Subject = "Hello World: " & Int(Timer) 'Indicates seconds since midnight
        .Send
    End With
    Set OutlookMail = Nothing
    SendCount = SendCount + 1
End Sub

Private Function ActivateTimer(ByVal Seconds As Long, TimerFunc As Long, ByRef TimerID As Long) 'The SetTimer call accepts milliseconds
    On Error Resume Next
    If TimerID = 0 Then TimerID = SetTimer(0, 0, Seconds * 1000, TimerFunc) 'Check to see if timer is running before call to SetTimer
End Function

Private Function DeactivateTimer(ByRef TimerID As Long)
    On Error Resume Next
    If KillTimer(0, TimerID) <> 0 Then TimerID = 0
End Function