遍历所有 Outlook 项目，查找包含特定文本的电子邮件正文的电子邮件

Question

我们有一个项目正在进行中，基本上它应该做以下事情：

1. 循环浏览所有 Outlook 项目（主电子邮件帐户及其子文件夹）
2. 遍历所有 Outlook 项目（用户创建的数据文件（PST 文件）及其子文件夹）
3. 上述两个循环应排除 Yammer Root、同步问题、联系人和日历文件夹
4. 查找电子邮件正文包含特定文本（例如 XXX-YY-2020777）的电子邮件，这对我来说是最重要的代码
5. 在工作表中打印这些：
   • 主文件夹-子文件夹
   • 发件人
   • 电子邮件主题
   • 收到日期

所以我在这里找到了一篇有用的帖子，感谢 Keith Whatling：

Sub GetEmail()

Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim myMail As Outlook.Items

Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")

On Error Resume Next
For Each Folder In Namespace.Folders
    For Each SubFolder In Folder.Folders
        For Each UserFolder In SubFolder.Folders
            Debug.Print Folder.Name, "|", SubFolder.Name, "|", UserFolder.Name
        Next UserFolder
    Next SubFolder
Next Folder
On Error GoTo 0

End Sub

我可以合并这两个帖子：

https://www.encodedna.com/excel/how-to-parse-outlook-emails-and-show-in-excel-worksheet-using-vba.htm 和

Excel vba: Looping through all subfolders in Outlook email to find an email with certain subject

但我需要一些指导，这样我才能开始。

Answer 1

我开始了

Sub GetEmailTesting()

Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace

Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")

Dim main_folder As Outlook.MAPIFolder
Dim sub_folder1 As Outlook.MAPIFolder
Dim sub_folder2 As Outlook.MAPIFolder
Dim sub_folder3 As Outlook.MAPIFolder

On Error Resume Next

For Each main_folder In namespace.Folders
    ' code goes here
     For Each sub_folder1 In main_folder.Folders
        ' code goes here
        For Each sub_folder2 In sub_folder1.Folders
            ' code goes here
            For Each sub_folder3 In sub_folder2.Folders
                    Dim rowNumber As Integer
                    rowNumber = 2
                    For Each obj_item In sub_folder3.Items
                        If obj_item.Class = olMail Then
                            Dim obj_mail As Outlook.MailItem
                            Set obj_mail = obj_item
                            Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
                            Cells(rowNumber, 2) = obj_mail.To
                            Cells(rowNumber, 3) = obj_mail.Subject
                            Cells(rowNumber, 4) = obj_mail.ReceivedTime
                        End If
                        rowNumber = rowNumber + 1
                    Next
            Next sub_folder3
        Next sub_folder2
    Next sub_folder1
Next main_folder

On Error GoTo 0

End Sub

我是否必须在每个 FOR EACH 循环中插入它（主文件夹、子文件夹 1、子文件夹 2、子文件夹 3 等等...？

                    For Each obj_item In sub_folder3.Items
                        If obj_item.Class = olMail Then
                            Dim obj_mail As Outlook.MailItem
                            Set obj_mail = obj_item
                            Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
                            Cells(rowNumber, 2) = obj_mail.To
                            Cells(rowNumber, 3) = obj_mail.Subject
                            Cells(rowNumber, 4) = obj_mail.ReceivedTime
                        End If
                        rowNumber = rowNumber + 1
                    Next