基于部分主题名回复最新已发送邮件的全部收件人

我的报告邮件主题格式为「Sales Report till 01-Sep-2022」，仅日期部分会变化，前缀「Sales Report till」固定。现有一段用于从已发送邮件执行「全部回复」的VBA代码，虽能完成回复操作，但存在缺陷：无法定位最新的目标邮件，会选中任意符合前缀的旧邮件（如上周或上月的）。需要修改代码，使其仅对最新的符合前缀的已发送邮件执行全部回复。

原代码 #

Sub OL_Email_Reply_To_All_WFN()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim objMail As Object
Dim objReplyToThisMail As MailItem
Dim lngCount As Long
Dim objConversation As Conversation
Dim objTable As Table
Dim objVar As Variant

Dim Path, WFN, SN As String
Dim WFN_Sub, WFN_RN, WFN_MB As String

Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\"    '''''Path to pick from "Main_Sheet" of ThisWorkbook
WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2")   ''''' Working File Name can be diffrent will change on sheet.
  
''''WFN_Sub = ThisWorkbook.Sheets("Main_Sheet").Range("B3")
''''WFN_RN = ThisWorkbook.Sheets("Main_Sheet").Range("B4")
''''WFN_MB = ThisWorkbook.Sheets("Main_Sheet").Range("B5")
''''WFN_SN = ThisWorkbook.Sheets("Main_Sheet").Range("B6")


'''''Original Subject Name looks like "Sales Report till 01-Sep-2022" in which date changes every everytime.

WFN_Sub = "Test Email"   '''''Subject to find should be intial only
WFN_RN = "Hi Friend"     '''''Recipient Name
WFN_MB = "Please ignore it's a Test Email"    ''''''''''Mail Body
    SN = "My Name"   '''''''''Senders Name

Set olApp = Session.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)

lngCount = 1

ThisWorkbook.Activate
For Each objMail In Fldr.Items
    If TypeName(objMail) = "MailItem" Then
        If InStr(objMail.Subject, WFN_Sub) <> 0 Then

            Set objConversation = objMail.GetConversation
            Set objTable = objConversation.GetTable
            objVar = objTable.GetArray(objTable.GetRowCount)
            Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))

            With objReplyToThisMail.ReplyAll
                .Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
                .HTMLBody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
                .display
                .Attachments.Add WFN
            End With
            Exit For
        End If
    End If

Next objMail
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
Set objMail = Nothing
Set objReplyToThisMail = Nothing
lngCount = Empty
Set objConversation = Nothing
Set objTable = Nothing
If IsArray(objVar) Then Erase objVar

End Sub

修改后的代码 #

Sub OL_Email_Reply_To_All_WFN()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim filteredItems As Items
Dim latestMail As MailItem
Dim objReplyToThisMail As MailItem
Dim objConversation As Conversation
Dim objTable As Table
Dim objVar As Variant

Dim Path, WFN, SN As String
Dim WFN_Sub, WFN_RN, WFN_MB As String

Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\"
WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2")

'' 设置正确的主题前缀
WFN_Sub = "Sales Report till"
WFN_RN = "Hi Friend"
WFN_MB = "Please ignore it's a Test Email"
SN = "My Name"

Set olApp = Session.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)

'' 筛选符合主题前缀的邮件，仅保留MailItem类型
Set filteredItems = Fldr.Items.Restrict("[MessageClass]='IPM.Note' AND [Subject] LIKE '%" & WFN_Sub & "%'")

'' 按发送时间降序排序，最新的邮件排在第一位
filteredItems.Sort "[SentOn]", olDescending

'' 检查是否有符合条件的邮件
If filteredItems.Count > 0 Then
    Set latestMail = filteredItems(1)
    
    Set objConversation = latestMail.GetConversation
    Set objTable = objConversation.GetTable
    objVar = objTable.GetArray(objTable.GetRowCount)
    Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))

    With objReplyToThisMail.ReplyAll
        .Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
        .HTMLBody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
        .Display
        .Attachments.Add WFN
    End With
Else
    MsgBox "未找到符合主题前缀的已发送邮件", vbInformation
End If

'' 释放对象
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
Set filteredItems = Nothing
Set latestMail = Nothing
Set objReplyToThisMail = Nothing
Set objConversation = Nothing
Set objTable = Nothing
If IsArray(objVar) Then Erase objVar

End Sub

关键修改说明 #

• 修正主题前缀：将WFN_Sub从测试用的「Test Email」改为实际的「Sales Report till」，确保筛选正确的目标邮件
• 高效筛选邮件：使用Items.Restrict方法直接过滤出符合条件的邮件，避免遍历全部已发送邮件，提升效率
• 按时间排序：对筛选后的邮件按SentOn（发送时间）降序排序，保证最新的邮件排在第一位
• 直接取最新邮件：无需循环遍历，直接取排序后的第一个邮件进行回复，彻底解决选中旧邮件的问题
• 添加异常处理：增加了无符合条件邮件时的提示，提升代码健壮性

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