Чтобы пройти через все папки, выполните следующие действия: Пройдите один раз через все основные папки в Outlook, а затем для каждой основной папки пройдите через каждую подпапку. Если у вас больше филиалов, то угадайте, что вам нужно добавить дополнительные уровни в код «для каждой папки3 в папке2.folders». Также в условии 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