仅使用部分主题名称回复所有最新发送的电子邮件

Question

我几乎没有每天发送的报告，有时根据要求，每周发送两次或三次，主题名称如“2022 年 9 月 1 日之前的销售报告”，其中只有日期发生变化，而像“销售报告直到 *”这样的首字母仍然是相同的。

下面是对已发送项目的“回复所有人”有效的代码。唯一的问题是它没有回复最新的已发送电子邮件。

意味着当它回复时，它会自动选择“Sales Report till”之后的任何电子邮件，无论发送的邮件是上周还是上个月。

大多数时候，电子邮件都会发生变化。所以我想在下面的代码中进行一些修改以在最新发送的电子邮件中回复所有内容。

上网找到了一些代码，但遗憾的是无法获得所需的输出。

在这方面的任何帮助将不胜感激

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

 

Answer 1

在获取表中的最后一行（从对话对象中检索）之前，您需要根据收到的日期 sort 项目：

 'Sort by ReceivedTime in descending order 
 table.Sort "[ReceivedTime]", True 

只有在那之后，您才可以依赖代码中的最后一项。

Answer 2

可能有更简单的代码。

Option Explicit

Sub OL_Email_Reply_To_All_WFN()

' reference Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Folder

Dim objMail As Object

Dim Path As String, WFN As String, SN As String
Dim WFN_Sub As String, WFN_RN As String, 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 = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderSentMail)

Dim fldrItems As Outlook.Items
Set fldrItems = olFldr.Items
fldrItems.Sort "[ReceivedTime]", True

Dim i As Long
For i = 1 To fldrItems.Count

    If TypeName(fldrItems(i)) = "MailItem" Then
        If InStr(fldrItems(i).Subject, WFN_Sub) <> 0 Then
        
            Debug.Print fldrItems(i).ReceivedTime
            
            With fldrItems(i).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

Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set fldrItems = Nothing
Set objMail = Nothing

End Sub