Сохранить вложения из MS Outlook в папку

По материалам: https://www.excel-vba.ru/chto-umeet-excel/soxranit-vlozheniya-iz-outlook-v-papku/

Sub SaveAttachedItemsFromOutlook()
' Сохранить вложения из Outlook в папку
' https://www.excel-vba.ru/chto-umeet-excel/soxranit-vlozheniya-iz-outlook-v-papku/
    
    Dim objOutlApp As Object, oNSpace As Object, oIncoming As Object
    Dim oIncMails As Object, oMail As Object, oAtch As Object
    Dim IsNotAppRun As Boolean
    Dim sFolder As String, s As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(4) '4 = msoFileDialogFolderPicker
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = "\", "", "\")
    'отключаем обновление экрана, чтобы наши действия не мелькали
    'Application.ScreenUpdating = False
 
    'подключаемся к Outlook
    On Error Resume Next
    Set objOutlApp = GetObject(, "Outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("Outlook.Application")
        IsNotAppRun = True
    End If
    'получаем доступ к папкам почты
    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    'подключаемся к папке Входящие, почтового ящика по умолчанию
    Set oIncoming = oNSpace.GetDefaultFolder(6)
    'Удаленные ==> GetDefaultFolder(3)
    'Исходящие ==> GetDefaultFolder(4)
    'Отправленные ==> GetDefaultFolder(5)
    'Входящие ==> GetDefaultFolder(6)
 
    'получаем коллекцию писем Входящие(включая подпапки)
    Set oIncMails = oIncoming.Items
    'просматриваем каждое письмо
    For Each oMail In oIncMails
        'просматриваем каждое вложение письма
        For Each oAtch In oMail.Attachments
            'отбираем только файлы Excel
            'If oAtch Like "*.xl*" Then
                s = GetAtchName(sFolder & oAtch)
               oAtch.SaveAsFile s
            'End If
        Next
    Next
    'Если приложение Outlook было открыта кодом - закрываем
    If IsNotAppRun Then
        objOutlApp.Quit
    End If
    'очищаем переменные
    Set oIncMails = Nothing
    Set oIncoming = Nothing
    Set oNSpace = Nothing
    Set objOutlApp = Nothing
    'возвращаем ранее отключенное обновление экрана
    'Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetAtchName
' Purpose   : Функция получения уникального имени файла
'             если файл с именем s уже есть - добавляет номер в скобках
'---------------------------------------------------------------------------------------
Function GetAtchName(ByVal s As String)
    Dim s1 As String, s2 As String, sEx As String
    Dim lu As Long, lp As Long
 
    s1 = s
    lp = InStrRev(s, ".", -1, 1)
    If lp Then
        sEx = Mid(s, lp)
        s1 = Mid(s, 1, lp - 1)
    End If
    s2 = s
    lu = 0
    Do While (Dir(s2, 16) <> "")
        lu = lu + 1
        s2 = s1 & "(" & lu & ")" & sEx
    Loop
    GetAtchName = s2
End Function