如何通过VBScript实现Outlook发送邮件后已发送邮件标记为未读？

我完全理解你的需求——之前用Lotus Notes发送的邮件会在已发送箱里留着未读标记，用户已经依赖这个特性做报告追踪，现在切换到Outlook的VBA脚本，不想靠用户规则来实现（毕竟人员变动时维护成本太高），这个需求非常实际。

核心思路 #

Outlook默认会把已发送的邮件自动标记为已读，我们只需要在邮件发送完成后，找到已发送箱里对应的那封邮件，手动把它的UnRead属性设为True就行。因为你的脚本是逐个发送邮件的，每次发送后立即处理对应的邮件，不会有冲突问题。

修改后的完整代码 #

下面是调整后的脚本，不仅修复了原代码里的语法小问题，还添加了标记未读的核心逻辑：

Sub SendWithOutlook() ' 修正Sub名称，更贴合当前功能
    Dim outobj As Object, mailobj As Object
    Dim ns As Object ' Outlook命名空间对象
    Dim sentFolder As Object ' 已发送邮件文件夹
    Dim vaRecipient As Variant, vsMsg As Variant, vaCC As Variant, stSubject As Variant, vaBCC As Variant
    Const stTitle As String = "Preview?"
    
    ' 预览确认逻辑
    If MsgBox("Did you already preview your message?", _
        vbYesNo + vbInformation, stTitle) = vbNo Then _
        Exit Sub
    
    ' 排序供应商列表
    Range("C2:C74").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
    
    Dim a As Integer, i As Integer
    a = 0
    i = 2
    
    ' 初始化Outlook核心对象
    Set outobj = CreateObject("Outlook.Application")
    Set ns = outobj.GetNamespace("MAPI")
    Set sentFolder = ns.GetDefaultFolder(5) ' 数字5对应Outlook的已发送邮件文件夹
    
    Do Until IsEmpty(Range("C" & i).Value)
        ' 读取Excel中的邮件参数
        vaRecipient = Range("D" & i).Value
        Range("A41").Value = Range("F" & i).Value
        vaMsg = Range("A83").Value
        vaCC = Range("A78").Value
        vaBCC = Range("H" & i).Value
        stSubject = Range("E" & i).Value
        stAttachment = Range("A113").Value
        stAttachment2 = Range("A114").Value
        stAttachment3 = Range("A115").Value
        stAttachment4 = Range("A116").Value
        stAttachment5 = Range("A117").Value
        
        ' 创建新邮件
        Set mailobj = outobj.CreateItem(0)
        With mailobj
            .To = vaRecipient
            If Range("B40").Value = "Yes" Then .CC = vaCC
            .BCC = vaBCC
            .Subject = stSubject
            .Body = vaMsg
            
            ' 添加附件（修复原代码多余的End If）
            If stAttachment <> "" Then .Attachments.Add (stAttachment)
            If stAttachment2 <> "" Then .Attachments.Add (stAttachment2)
            If stAttachment3 <> "" Then .Attachments.Add (stAttachment3)
            If stAttachment4 <> "" Then .Attachments.Add (stAttachment4)
            If stAttachment5 <> "" Then .Attachments.Add (stAttachment5)
            
            ' 发送邮件
            .Send
            
            ' 关键操作：标记已发送邮件为未读
            Dim sentMail As Object
            ' 取已发送文件夹中最新的邮件（因为逐个发送，最新的就是刚发的那封）
            Set sentMail = sentFolder.Items.GetLast()
            sentMail.UnRead = True
            sentMail.Save ' 保存修改
        End With
        
        ' 释放当前邮件对象，避免内存泄漏
        Set mailobj = Nothing
        Set sentMail = Nothing
        
        a = a + 1
        AppActivate "SendWithOutlook"
        i = i + 1
    Loop
    
    Range("A41").Value = ""
    MsgBox "You have successfully sent " & a & " email(s). Danny is Awesome.", vbInformation
    
    ' 释放所有Outlook对象
    Set sentFolder = Nothing
    Set ns = Nothing
    Set outobj = Nothing
End Sub

关键修改说明 #

1. 添加Outlook命名空间和已发送文件夹引用：通过ns.GetDefaultFolder(5)直接获取默认的已发送邮件文件夹，不用手动定位。
2. 发送后标记未读：在.Send执行完成后，用sentFolder.Items.GetLast()拿到刚发送的邮件，设置UnRead = True并保存，完美复刻Lotus Notes的行为。
3. 修复语法错误：原代码里有几处多余的End If（比如CC判断后的额外结束语句），已经一并修正，避免脚本报错。
4. 优化对象管理：所有Outlook相关对象都在最后释放，减少内存占用问题。

精准匹配备选方案（适合高频发送场景） #

如果担心同时有其他邮件发送导致GetLast()取错邮件，可以用主题+时间范围来精准匹配：

' 替换原关键部分的标记代码
.Send

' 查找10秒内发送的、主题匹配的邮件
Dim sentMail As Object
Dim filterStr As String
' 处理主题里的单引号，避免搜索语法错误
filterStr = "[Subject] = '" & Replace(stSubject, "'", "''") & "' AND [SentOn] >= '" & Format(Now() - TimeValue("00:00:10"), "ddddd hh:mm:ss") & "'"
Set sentMail = sentFolder.Items.Find(filterStr)
If Not sentMail Is Nothing Then
    sentMail.UnRead = True
    sentMail.Save
End If

这个方法会在已发送文件夹里筛选最近10秒内发送的、主题完全匹配的邮件，彻底避免误判，适合邮件发送频率较高的场景。

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