Excel VBA实现筛选表格批量发邮件及自动发送功能咨询

• 日常需要向各承包商发送邮件跟进已投标项目进度
• 原有VBA宏需要手动在引用单元格逐个输入对接销售代表姓名才能执行，对接数十位销售时操作效率极低
• 需求为单次运行宏即可向所有关联项目状态为Open的销售代表批量发送邮件，无需每次手动修改收件人
• 原有代码调用.Send自动发送方法始终无法正常运行，不希望继续使用.Display方法逐封弹出邮件确认发送

• 拼写错误：GetObject传入的Outlook对象名多了多余空格，ListObjects方法名、自定义变量名存在拼写不一致问题，导致Outlook实例、表格对象无法正确加载，是.Send方法失效的核心原因
• 逻辑缺陷：固定读取单个单元格值作为收件人，没有做全表遍历、联系人去重逻辑，无法实现批量发送
• 错误处理不合理：全局使用On Error Resume Next吞掉所有运行报错，出现问题时无法定位故障点
• 状态管理缺失：运行前未关闭屏幕更新，运行后未做异常场景下的表格状态恢复，容易出现闪屏、表格列长期隐藏、筛选未清除的问题

Sub BatchSendOpenStatusEmails()
    '声明Outlook相关变量
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    Dim oLookIns As Outlook.Inspector
    Dim oWrdDoc As Word.Document
    
    '声明Excel相关变量
    Dim ws As Worksheet
    Dim sourceTbl As ListObject
    Dim dataRow As ListRow
    Dim salesDict As Object
    Dim salesEmail As String
    Dim salesName As String
    
    '可根据实际表格结构调整以下配置参数
    Const STATUS_COL As Integer = 6       '项目状态所在表格列序号
    Const EMAIL_COL As Integer = 4        '销售邮箱所在表格列序号
    Const NAME_COL As Integer = 6         '销售姓名所在表格列序号
    Const TARGET_STATUS As String = "Open"'需要跟进的项目状态值
    
    Application.ScreenUpdating = False
    
    '获取Outlook应用实例
    On Error Resume Next
    Set oLookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set oLookApp = New Outlook.Application
        Err.Clear
    End If
    On Error GoTo ErrHandler
    
    '绑定数据源表
    Set ws = ActiveSheet
    Set sourceTbl = ws.ListObjects("Table1")
    Set salesDict = CreateObject("Scripting.Dictionary")
    
    '遍历全表提取所有名下有Open状态项目的销售，自动去重
    For Each dataRow In sourceTbl.ListRows
        If dataRow.Range.Columns(STATUS_COL).Value = TARGET_STATUS Then
            salesEmail = Trim(dataRow.Range.Columns(EMAIL_COL).Value)
            salesName = Trim(Split(dataRow.Range.Columns(NAME_COL).Value, " ")(0))
            If salesEmail <> "" And Not salesDict.Exists(salesEmail) Then
                salesDict.Add salesEmail, salesName
            End If
        End If
    Next dataRow
    
    '无符合条件收件人时直接退出
    If salesDict.Count = 0 Then
        MsgBox "未找到关联Open状态项目的销售联系人，无邮件需要发送", vbInformation
        GoTo Cleanup
    End If
    
    '逐封生成并发送邮件
    For Each salesEmail In salesDict.Keys
        salesName = salesDict(salesEmail)
        Set oLookItm = oLookApp.CreateItem(olMailItem)
        
        With oLookItm
            .To = salesEmail
            .Subject = "Various Project Statuses"
            .Display '临时调用用于获取Word编辑器权限，不会停留等待手动确认
            
            Set oLookIns = .GetInspector
            Set oWrdDoc = oLookIns.WordEditor
            
            '筛选当前销售名下的Open状态项目
            sourceTbl.Range.AutoFilter Field:=STATUS_COL, Criteria1:=TARGET_STATUS
            sourceTbl.Range.AutoFilter Field:=EMAIL_COL, Criteria1:=salesEmail
            
            '隐藏无需展示的列
            ws.Range("G:R").EntireColumn.Hidden = True
            
            '粘贴表格内容到邮件正文
            sourceTbl.Range.Copy
            oWrdDoc.Paragraphs(1).Range.Paste
            
            '插入问候语
            Dim msgText As String
            msgText = salesName & "," & vbNewLine & "Can you please let me know the statuses of the projects below." & vbNewLine & vbNewLine
            oWrdDoc.Range(0, 0).InsertBefore msgText
            
            '自动发送邮件
            .Send
        End With
        
        '释放单封邮件相关对象
        Set oLookItm = Nothing
        Set oWrdDoc = Nothing
        Set oLookIns = Nothing
    Next salesEmail
    
    MsgBox "全部" & salesDict.Count & "封项目跟进邮件已自动发送完成", vbInformation

Cleanup:
    '恢复表格初始状态
    If Not sourceTbl.AutoFilter Is Nothing Then sourceTbl.AutoFilter.ShowAllData
    Application.CutCopyMode = False
    ws.Range("G:R").EntireColumn.Hidden = False
    '释放所有对象
    Set salesDict = Nothing
    Set sourceTbl = Nothing
    Set ws = Nothing
    Set oLookApp = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "运行出错，错误信息：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

• 首次运行前请确认VBA编辑器中已勾选Microsoft Outlook Object Library和Microsoft Word Object Library引用
• 代码开头的常量参数可根据实际表格的列位置、目标状态值自行调整
• 运行时会自动遍历全表匹配符合条件的联系人，无需手动修改单元格内容，全程不会弹出邮件窗口要求手动确认发送
• 若遇到Outlook安全弹窗拦截自动发送，可在Outlook信任中心设置允许程序发送邮件，或临时降低宏安全等级

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