Excel VBA批量发邮件：解决Outlook单邮500收件人限制问题

针对现有代码的问题，以下修改实现了按每500个收件人分组发送的逻辑，同时修复了原代码中未正确使用OFT模板的问题：

核心修改点： #

• 新增recipientCount计数器，统计当前邮件的收件人数量，达到500时触发发送并重置
• 用toList字符串拼接符合条件的收件人地址，避免逐个发送单封邮件
• 循环结束后处理剩余未发送的收件人
• 正确调用OFT模板创建邮件，保留模板中的格式和内容

修改后的完整代码： #

Option Explicit

Sub GroupSendEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim toList As String
    Dim recipientCount As Integer
    Const MAX_RECIPIENTS As Integer = 500 ' 每封邮件最大收件人数

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    recipientCount = 0
    toList = ""

    ' 遍历B列中所有常量单元格（邮箱地址）
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        ' 验证邮箱格式且F列为小写x
        If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "x" Then
            ' 拼接收件人地址，用分号分隔
            toList = toList & cell.Value & ";"
            recipientCount = recipientCount + 1

            ' 达到收件人上限时，创建并发送邮件
            If recipientCount >= MAX_RECIPIENTS Then
                Set OutMail = OutApp.CreateItemFromTemplate("C:\Change Notification.oft")
                With OutMail
                    .SentOnBehalfOfName = "shared@abccorp.com"
                    .To = Left(toList, Len(toList) - 1) ' 移除最后一个分号
                    .Send ' 如需预览可改为.Display
                End With
                Set OutMail = Nothing
                ' 重置计数器和收件人列表
                recipientCount = 0
                toList = ""
            End If
        End If
    Next cell

    ' 发送最后一批剩余的收件人
    If recipientCount > 0 Then
        Set OutMail = OutApp.CreateItemFromTemplate("C:\Change Notification.oft")
        With OutMail
            .SentOnBehalfOfName = "shared@abccorp.com"
            .To = Left(toList, Len(toList) - 1)
            .Send
        End With
        Set OutMail = Nothing
    End If

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

使用说明： #

• 确保C:\Change Notification.oft路径正确指向你的邮件模板文件
• 若需要测试，可将.Send改为.Display，先预览邮件再手动发送
• 代码会自动过滤不符合邮箱格式且未标记x的行

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