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

Сегодня я хотел бы поделиться очередным решением с использованием Outlook. Задача сохранить все файлы Excel, хранящиеся как вложения, из папки Входящие(Inbox) на диск. Решение достигается только применением кода на VBA. Код ниже не имеет практически никаких настроек - он просто сохраняет абсолютно все вложения Excel из папки Входящие(включая подпапки):

Sub SaveAttachedItemsFromOutlook()
    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(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    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

Код необходимо поместить в стандартный модуль и запустить. Или скачать приложенный ниже файл - там уже есть и кнопка для запуска:

  Tips_GetOutlookAttach.xls (54,0 KiB, 3 490 скачиваний)

После запуска код попросит указать папку, в которую сохранять вложения. После этого все вложения, являющиеся файлами Excel, будут сохранены в указанную папку. Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).
Код имеет некоторые недостатки:

• нет возможности отобрать какие-то другие файлы, кроме Excel. Это легко исправить, если в строке If oAtch Like "*.xl*" Then вместо "xl*" указать нужное расширение. Например "*.png" или "*.gif"
• нет возможности выбрать папку для просмотра вложений - просматриваются абсолютно все письма папки Входящие учетной записи по умолчанию. Но можно указать только папку, отличную от Входящих: Удаленные, Исходящие, Отправленные - в коде есть комментарий с числовыми константами этих папок. Но в этих папках как правило вложения не просматривают
• и самый большой недостаток - нельзя выбрать учетную запись Outlook, для которой просматривать Входящие. Просмотр возможен исключительно в учетной записи, установленной по умолчанию

  Tips_GetOutlookAttach_Advanced.xls (91,5 KiB, 4 362 скачиваний)

Просматривать все папки - если установлен, то вложения будут просматриваться во всех письмах папки Входящие(включая все подпапки).

Выберите папку для сохранения вложений - кнопкой справа от поля выбирается папка, в которую надо сохранить все найденные вложения.

Отбирать вложения - указываются маски для типов файлов, которые необходимо отбирать. По умолчанию установлена маска "*.*" - отбирать все файлы. Однако можно указать любой тип файлов. Например, если указать "*.jpeg" - будут отобраны исключительно рисунки с расширением .jpeg. Если необходимо отбирать файлы более одного типа, то все маски можно перечислить через прямую черту - |. Например, чтобы отобрать все файлы Word, Excel и PowerPoint следует указать такую маску: "*.doc*|*.xl*|*.ppt*". Тут есть и еще один нюанс - таким образом можно указать маску не только форматов, но и имен файлов. К примеру, чтобы отобрать только файлы Excel, содержащие в имени слово "отчет" необходимо задать такую маску: "*отчет*.xl*".

После нажатия СОХРАНИТЬ ВЛОЖЕНИЯ внизу формы отобразится информационное окно, показывающее в какой папке идет поиск вложений и каков прогресс выполнения операции поиска в этой папке(на картинке это зеленая полоса внизу формы). Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).

В обоих кодах и файлах используется обращение к индексам папок, которые используются в Outlook по умолчанию:
Удаленные ==> GetDefaultFolder(3)
Исходящие ==> GetDefaultFolder(4)
Отправленные ==> GetDefaultFolder(5)
Входящие ==> GetDefaultFolder(6)
но здесь кроется маленький нюанс: порядок папок на некоторых ПК может отличаться(как правило это либо на серверных версиях, либо вследствие вмешательства в структуру папок). Поэтому, если отбор из папок не идет - можно попробовать найти нужную следующим кодом:

Sub FindIncomingFolder() Dim objOutlApp As Object, oNSpace As Object, i As Long On Error Resume Next Set objOutlApp = GetObject(, "outlook.Application") If objOutlApp Is Nothing Then Set objOutlApp = CreateObject("outlook.Application") End If Set oNSpace = objOutlApp.GetNamespace("MAPI") For i = 1 To 50 MsgBox i & " = " & oNSpace.GetDefaultFolder(i) Next End Sub

Sub FindIncomingFolder() Dim objOutlApp As Object, oNSpace As Object, i As Long On Error Resume Next Set objOutlApp = GetObject(, "outlook.Application") If objOutlApp Is Nothing Then Set objOutlApp = CreateObject("outlook.Application") End If Set oNSpace = objOutlApp.GetNamespace("MAPI") For i = 1 To 50 MsgBox i & " = " & oNSpace.GetDefaultFolder(i) Next End Sub

Тогда достаточно будет запустить код и посмотреть какому номеру в показываемых сообщениях соответствует папка Входящие(Incoming).

Так же см.:
Сохранить вложения из Outlook
Как отправить письмо из Excel?
Вставить в письмо Outlook таблицу Excel с форматированием
Вставить в письмо подпись из Outlook через VBA
Как отправить письмо от другой учетной записи Outlook

    Видеоуроки

Поиск по меткам