使用 Excel VBA 搜索 Outlook 电子邮件（并回复）

Question

我想在我的所有 Outlook 中搜索对话中的最新消息（我使用主题名称作为搜索键）。

这条最新消息可以在收件箱、已发送邮件、收件箱的子文件夹、收件箱的子文件夹中（任何地方）。

我可以通过一些非常繁琐的代码来实现这一点，遍历每个主要文件夹的每一级，但这种方法不仅非常混乱，我无法确定这个找到的消息是否是这次对话中最新的。

我有以下代码，其中

--> 在收件箱中搜索“searchKey”

--> 如果在收件箱文件夹中找到，回复它

--> 如果没有，它会移动到收件箱的子文件夹中，并继续相同的过程

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr

tryAgain:

    For Each olMail In olFldr.Items
        If InStr(olMail.Subject, searchKey) <> 0 Then
            Set ReplyAll = olMail.ReplyAll
            With ReplyAll
                .HTMLBody = Msg & .HTMLBody
                emailReady = True
                .Display
            End With
        End If
    Next olMail


If Not emailReady Then
    i = i + 1
    If i > Fldr.Folders.Count Then
        MsgBox ("The email with the given subject line was not found!")
        Exit Sub
    Else
        Set olFldr = Fldr.Folders(i)
        GoTo tryAgain
    End If
End If

此代码可能会令人困惑且冗长，因此如果您需要任何说明，请告诉我。

问题是：我如何在所有 Outlook 中进行搜索，而无需手动遍历每个文件夹/子文件夹/子子文件夹...没有这种方法，并在特定对话中找到最后一条消息？或者，至少，我怎样才能优化这段代码，这样我就不会错过任何文件夹，并且知道这些电子邮件的发送日期和时间？

Answer 1

您可以使用内置的AdvancedSearch 函数，该函数返回一个包含项目的搜索对象。 这些应该具有日期属性，因此您只需要您的代码通过搜索对象 mailItems 并找到最新日期（ReceivedTime）吗？

我建议使用该页面上的底部示例 - 它从搜索中获取一个表格对象，然后您使用

Set MyTable = MySearch.GetTable  
Do Until MyTable.EndOfTable  
    Set nextRow = MyTable.GetNextRow()  
    Debug.Print nextRow("ReceivedTime")  
Loop

从那里，您可以进行比较以找到最近的时间，如果您想对 mailitem 做一些事情，您需要从表中获取“EntryID”列。 然后使用 NameSpace 对象的 GetItemFromID 方法获取完整的项目，因为该表返回只读对象。

如果您愿意，也可以将日期过滤器应用于搜索，例如，如果您知道最短日期。

Answer 2

要浏览所有文件夹，请执行以下操作： 浏览一次 Outlook 中的所有主文件夹，然后为每个主要文件夹浏览每个子文件夹。如果您有更多分支，那么猜测您必须为“对于 folder2.folders 中的每个 Folder3”的代码添加更多级别。同样在 if 子句中，您可以测试邮件的日期并从最新到最旧。设置oMsg.display查看正在检查的邮件

Public Sub FORWARD_Mail_STAT_IN()
Dim Session As Outlook.NameSpace
Dim oOutLookObject As New Outlook.Application
Dim olNameSpace As NameSpace
Dim oItem As Object
Dim oMsg As Object
Dim searchkey As String

Set oOutLookObject = CreateObject("Outlook.Application")
Set oItem = oOutLookObject.CreateItem(0)
Set olNameSpace = oOutLookObject.GetNamespace("MAPI")

Set Session = Application.Session
Set Folders = Session.Folders
For Each Folder In Folders  'main folders in Outlook

        xxx = Folder.Name
           For Each Folder2 In Folder.Folders  'all the subfolders from a main folder
            yyy = Folder2.Name
             Set oFolder = olNameSpace.Folders(xxx).Folders(yyy)  'in each folder we search all the emails

              For Z = oFolder.Items.Count To 1 Step -1 ' For Z = 1 To oFolder.Items.Count
                  With oFolder.Items(Z)
                   Set oMsg = oFolder.Items(Z)

                    If Format(oMsg.SentOn, "mm/dd/yyyy") = Format(Date, "mm/dd/yyyy") And InStr(1, LCase(oMsg.Subject), searchkey, vbTextCompare) > 0 Then 
oMsg.display
                        '  insert code
                        End If
                      End With
                  Next Z
           Next Folder2
        Next Folder