0

I'm using the following code for my mail-merge with Outlook.

Sub sendEmailWithAttachments()
    
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim myAttachments As Object
    Dim row As Integer
    Dim col As Integer
    
    Set OutLookApp = CreateObject("Outlook.application")
    row = 2
    col = 1
    ActiveSheet.Cells(row, col).Select
    Do Until IsEmpty(ActiveCell)
        Set OutLookMailItem = OutLookApp.CreateItemFromTemplate(Application.ActiveWorkbook.Path & "\" & "message.oft")
        Set myAttachments = OutLookMailItem.Attachments
        'Do Until IsEmpty(ActiveCell)
        Do Until IsEmpty(ActiveSheet.Cells(1, col))
            With OutLookMailItem
                If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
                    'MsgBox ("Exiting...")
                    Exit Sub
                End If
                If ActiveSheet.Cells(1, col).Value = "To" And Not IsEmpty(ActiveCell) Then
                    .To = .To & "; " & ActiveSheet.Cells(row, col).Value
                ElseIf ActiveSheet.Cells(1, col).Value = "Cc" And Not IsEmpty(ActiveCell) Then
                    .CC = .CC & "; " & ActiveSheet.Cells(row, col).Value
                ElseIf ActiveSheet.Cells(1, col).Value = "Bcc" And Not IsEmpty(ActiveCell) Then
                    .BCC = .BCC & "; " & ActiveSheet.Cells(row, col).Value
                ElseIf ActiveSheet.Cells(1, col).Value = "attachment" And Not IsEmpty(ActiveCell) Then
                    myAttachments.Add Application.ActiveWorkbook.Path & "\" & ActiveSheet.Cells(row, col).Value
                ElseIf ActiveSheet.Cells(1, col).Value = "xxxignorexxx" Then
                    ' Do Nothing
                Else
                    .Subject = Replace(.Subject, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
                    'Write #1, .HTMLBody
                    .HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
                    'ActiveSheet.Cells(10, 10) = .HTMLBody
                End If
                
                'MsgBox (.To)
            End With
            'Application.Wait (Now + #12:00:01 AM#)
            
            col = col + 1
            ActiveSheet.Cells(row, col).Select
        Loop
        OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
        OutLookMailItem.send
        col = 1
        row = row + 1
        ActiveSheet.Cells(row, col).Select
    Loop

End Sub

With this code, all emails in the Excel file go to the Outlook outbox. When they are all in the outbox, I launch the send and they leave one after the other.

I need the sending of all emails delayed by five seconds from each other.

Community
  • 1
  • 1
Stefano Morelli
  • 1
  • Welcome to SO. Try adding `Application.Wait (Now + TimeValue("0:00:05"))` right after `OutLookMailItem.send` – Foxfire And Burns And Burns Mar 13 '23 at 13:06
  • You can add in a delay using the following code: https://stackoverflow.com/a/49389094/3688861 however receipt is asynchronous so because they are sent 5 seconds apart there is no guarantee they will arrive in the same order or 5 seconds apart – Tragamor Mar 13 '23 at 14:27
  • @foxfire Thank's. That function delays sending to the outlook outbox by five seconds, but not exiting the outlook outbox. I need a delay from the outlook mailbox of five seconds – Stefano Morelli Mar 14 '23 at 13:38
  • See [Resend emails stuck in Outbox](https://stackoverflow.com/questions/66285778/resend-emails-stuck-in-outbox). – niton Mar 19 '23 at 12:24

0 Answers0