遍历Excel行批量发送Outlook邮件时第二行报错问题

错误根源 #

你只初始化了一次objMail对象，第一次发送邮件后，这个对象对应的邮件已经被Outlook发送并转移到已发送文件夹，第二次循环再调用这个对象时，它已经无效，所以触发「项目已被移动或删除」的错误。

修复要点 #

• 每次发送邮件前都要重新创建新的objMail实例，不能复用同一个对象
• 替换GoTo和Select写法，用更清晰的Do...Loop循环遍历行，代码更易维护
• 给所有变量声明明确类型，避免变体类型带来的潜在问题
• 增加附件文件存在检查，防止因文件缺失导致的报错

修正后的完整代码 #

Sub email_Advice()
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngSubject As Range
    Dim rngRef As Range
    Dim rngBody As Range
    Dim ID As String
    Dim XX As Long
    Dim attachmentPath As String
    
    '初始化Outlook应用
    Set objOutlook = CreateObject("Outlook.Application")
    ID = CreateObject("WScript.Network").UserName
    XX = 8 '从第8行开始
    
    Do
        '检查当前行V列是否为空
        If Range("V" & XX).Value = "" Then
            '检查U列是否为空，判断是否终止循环
            If Range("U" & XX).Value = "" Then
                Exit Do
            End If
            
            '获取当前行的邮件信息
            With ActiveSheet
                Set rngTo = .Range("M" & XX)
                Set rngSubject = .Range("O" & XX)
                Set rngBody = .Range("P" & XX)
                Set rngRef = .Range("T" & XX)
            End With
            
            '创建新的邮件对象（关键：每次循环都新建）
            Set objMail = objOutlook.CreateItem(0)
            
            '拼接附件路径
            attachmentPath = "C:\Users\" & ID & "\Desktop\WHT \" & rngRef.Value & ".pdf"
            
            With objMail
                .To = rngTo.Value
                .Subject = rngSubject.Value
                .Body = rngBody.Value
                '检查附件文件是否存在
                If Dir(attachmentPath) <> "" Then
                    .Attachments.Add attachmentPath
                Else
                    MsgBox "附件不存在：" & attachmentPath, vbExclamation
                End If
                .Send
            End With
            
            '标记已发送
            Range("V" & XX).Value = "YES"
        Else
            'V列不为空，直接退出循环
            Exit Do
        End If
        
        XX = XX + 1 '移到下一行
    Loop Until Range("V" & XX).Value = "" And Range("U" & XX).Value = "" '终止条件
    
    '释放对象
    Set objMail = Nothing
    Set objOutlook = Nothing
    Set rngTo = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing
    Set rngRef = Nothing
End Sub

额外说明 #

• 如果需要手动确认每封邮件的发送，可以把.Send改成.Display，手动点击发送按钮
• 新增的附件存在检查，能避免因路径错误或文件丢失导致的额外报错
• 用Do...Loop替代GoTo，代码逻辑更直观，后续修改和维护更方便

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