Обработка вложенных папок, папки «Входящие»

Option Explicit
    Dim Юзер As String, path_att$, file_ext$
    Dim newItem
    Dim att As Outlook.Attachment
    Const Путь As String = "E:\ФАЙЛЫ ПОЧТЫ\"
    Private Sub ПЕРЕМЕННЫЕ()
        Юзер = CreateObject("WScript.Network").UserName
        file_ext = "doc_docx_xls_xlsx_xlsm_pdf_zip_7z_rar_"
        Set newItem = Application.CreateItemFromTemplate("C:\Users\" & Юзер & "\AppData\Roaming\Microsoft\Templates\name.oft")
    End Sub
    '==========================================================================================================================='
 
Public Sub Папка()
    CreateObject("Shell.Application").explore (Путь)
End Sub
 
 
Public Sub СохранитьВложения(Msg As Outlook.MailItem): ПЕРЕМЕННЫЕ 'object
    Dim base_path As String:   base_path = Путь
    Dim v_dateFormat:       v_dateFormat = Format(Msg.CreationTime, "yyyy-mm-dd HH-mm-ss") 'CreationTime - дата загрузки, ReceivedTime - дата отправки
    Dim v_year:                   v_year = Format(Msg.ReceivedTime, "yyyy")
    Dim v_month:                 v_month = Format(Msg.ReceivedTime, "mm.mmmm")
 
    For Each att In Msg.Attachments
                            v_dateFormat = Format(Msg.CreationTime, "yyyy-mm-dd HH-mm-ss")
        Dim s As String:               s = att.FileName
        Dim pd As Integer:            pd = InStrRev(s, ".")
        Dim n As String:               n = Left(s, pd - 1)
        Dim w As String:               w = Right(s, Len(s) - pd)
        If InStr(1, file_ext, w) > 0 Then
            path_att = base_path & v_year:                      If Not Dir(path_att, vbDirectory) <> "" Then MkDir (path_att)
            path_att = path_att & "\" & v_month:                If Not Dir(path_att, vbDirectory) <> "" Then MkDir (path_att)
            path_att = path_att & "\" & Msg.SenderEmailAddress: If Not Dir(path_att, vbDirectory) <> "" Then MkDir (path_att) 'SenderName - имя отправителя, SenderEmailAddress - email отправителя
            Do
                v_dateFormat = Format(Msg.ReceivedTime, "yyyy.mm.dd-ddd")
            Loop Until Not Dir(path_att & "\" & n & v_dateFormat & "." & w) <> ""
            att.SaveAsFile path_att & "\" & v_dateFormat & ", " & n & "." & w
        End If
    Next
End Sub
 
'Outlook 2016
'HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security
'DWORD: EnableUnsafeClientMailRules
'Value: 1
'
'Outlook 2013
'HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Security
'DWORD: EnableUnsafeClientMailRules
'Value: 1
'
'Outlook 2010
'HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Outlook\Security
'DWORD: EnableUnsafeClientMailRules
'Value: 1

Sub reestrFind(ByVal subfoldername As String)
Dim FSO As Object
Dim tmpArr() As String
Dim sourcefolder As Object
Dim FSOTXT As Object
Dim FileNumber As Integer
 
Set FSO = CreateObject("scripting.filesystemobject")
Set sourcefolder = FSO.getfolder(subfoldername)
For Each Fileitem In sourcefolder.Files
 
    If Fileitem.Name Like "*.txt" And Fileitem.Size <> 0 Then
' действия
  End If
 
Next Fileitem
 
For Each subfolder In sourcefolder.subfolders
   
        reestrFind (subfolder.Path)
 
Next subfolder
 
Set subfolder = Nothing
 
Set Fileitem = Nothing
 
Set FSO = Nothing
 
End Sub