如何实现Outlook邮件合并时邮件间隔5秒依次发送？

问题描述 #

我用以下VBA代码实现Excel与Outlook的邮件合并，代码会把所有邮件批量导入Outlook发件箱，触发发送后邮件会连续发出。现在需要让所有邮件彼此间隔5秒依次发送，请提供解决方案。

原代码：

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

解决方案 #

提供三种可行方案，可根据需求选择：

方案1：直接添加等待逻辑（简单适配原代码） #

修改原代码，在每发送一封邮件后添加5秒等待，确保间隔发送：

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(ActiveSheet.Cells(1, col))
            With OutLookMailItem
                If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
                    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)
                    .HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
                End If
            End With
            col = col + 1
            ActiveSheet.Cells(row, col).Select
        Loop
        OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
        ' 发送当前邮件
        OutLookMailItem.Send
        ' 等待5秒后处理下一封
        Application.Wait Now + TimeValue("00:00:05")
        
        col = 1
        row = row + 1
        ActiveSheet.Cells(row, col).Select
    Loop

End Sub

• 说明：Application.Wait会让Excel暂停5秒，期间界面无法操作，但能保证严格的发送间隔；需确保Outlook处于联机状态，否则邮件会留在发件箱，间隔不生效。

方案2：使用API Sleep函数（更精准延迟） #

如果需要更精准的延迟，可调用Windows API的Sleep函数，在模块顶部先声明API：

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

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(ActiveSheet.Cells(1, col))
            With OutLookMailItem
                If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
                    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)
                    .HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
                End If
            End With
            col = col + 1
            ActiveSheet.Cells(row, col).Select
        Loop
        OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
        ' 发送当前邮件
        OutLookMailItem.Send
        ' 延迟5000毫秒（5秒）
        Sleep 5000
        
        col = 1
        row = row + 1
        ActiveSheet.Cells(row, col).Select
    Loop

End Sub

• 说明：Sleep函数精准延迟指定毫秒数，相比Application.Wait不会强制等待到某个时间点，但Excel界面会暂时无响应，延迟结束后恢复正常。

方案3：草稿箱定时发送（不卡住Excel） #

如果不想让Excel在发送期间卡住，可先将所有邮件保存为草稿，再通过定时任务逐个发送：

步骤1：保存所有邮件为草稿

Sub saveAllDrafts()
    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(ActiveSheet.Cells(1, col))
            With OutLookMailItem
                If ActiveSheet.Cells(row, col).Value = "xxxFINISHxxx" Then
                    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)
                    .HTMLBody = Replace(.HTMLBody, ActiveSheet.Cells(1, col).Value, ActiveSheet.Cells(row, col).Value)
                End If
            End With
            col = col + 1
            ActiveSheet.Cells(row, col).Select
        Loop
        OutLookMailItem.HTMLBody = Replace(OutLookMailItem.HTMLBody, "xxxNLxxx", "<br>")
        ' 保存为草稿，不发送
        OutLookMailItem.Save
        
        col = 1
        row = row + 1
        ActiveSheet.Cells(row, col).Select
    Loop
    ' 启动定时发送
    Call sendDraftsWithInterval(5)
End Sub

步骤2：定时发送草稿

Dim draftIndex As Integer
Dim outApp As Object

Sub sendDraftsWithInterval(intervalSeconds As Integer)
    Set outApp = CreateObject("Outlook.application")
    draftIndex = 1
    ' 首次发送立即执行
    Application.OnTime Now, "sendNextDraft"
End Sub

Sub sendNextDraft()
    Dim draftFolder As Object
    Dim draftMail As Object
    
    Set draftFolder = outApp.GetNamespace("MAPI").GetDefaultFolder(3) ' 3 = 草稿箱
    If draftIndex <= draftFolder.Items.Count Then
        Set draftMail = draftFolder.Items(draftIndex)
        draftMail.Send
        draftIndex = draftIndex + 1
        ' 定时发送下一封
        Application.OnTime Now + TimeValue("00:00:" & intervalSeconds), "sendNextDraft"
    Else
        ' 所有草稿发送完成，清理对象
        Set draftMail = Nothing
        Set draftFolder = Nothing
        Set outApp = Nothing
    End If
End Sub

• 说明：运行saveAllDrafts将邮件保存为草稿后，会自动每5秒发送一封；发送期间可正常操作Excel；建议先清空草稿箱再运行，避免发送无关邮件。

内容的提问来源于stack exchange，提问作者Stefano Morelli