Сохранить вложения из многих писем одновременно в Outlook?

Надстройка для удаления вложений в Outlook:

Бесплатная надстройка Outlook для сохранения и распаковки вложений, уменьшения размера ваших файлов Outlook. Легко использовать. Множество функций.

Вот еще несколько вариантов с этим.

Сайт Сью Мошер http://slipstick.com/ - фантастический ресурс для Outlook. Она также является Microsoft MVP.

Для программистов: сохраняйте вложения на жестком диске и, альтернативно, сохраняйте и открывайте вложения с помощью VBA.

Следующий код работает в Outlook 2000 и выше. Он сохраняет вложения из выбранных сообщений, но не удаляет вложения из сообщений.

...

Скопируйте и вставьте код с этой страницы в ваш проект ThisOutlookSession.

В Outlook нажмите Alt+F11, чтобы открыть редактор VBA и развернуть объекты Microsoft Outlook, затем дважды щелкните ThisOutlookSession, чтобы открыть его на панели редактирования, и Ctrl+V, чтобы вставить код.

Чтобы использовать его, вы должны сначала создать папку в папке "Мои документы" с именем OLAttachments (код не создаст ее для вас). Затем выберите одно или несколько сообщений и запустите макрос, чтобы сохранить вложения. Вам нужно установить защиту макросов, чтобы они предупреждали перед включением макросов или подписали макрос. Вы можете изменить имя или путь к папке, в которой сохраняются вложения, отредактировав код.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

' The attachment folder needs to exist
' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\OLAttachments\"

    ' Check each selected item for attachments. 
    For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1

    ' Get the file name.
    strFile = objAttachments.Item(i).FileName

    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile

    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile

    Next i
    End If

    Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

И если вы не хотите программировать: Инструменты управления вложениями для Outlook

После того, как меня разбомбили электронные письма от человека, который подумал, что было бы неплохо отправить мне разделенный RAR-файл на 30 писем, я успешно использовал этот сценарий VBA, опубликованный Microsoft, под названием mAttachmentSaver,

Сначала вам нужно скачать архив, содержащий скрипт.

Важно, чтобы макросы были включены. В Outlook 2010 вы можете сделать это, перейдя в Файл "Параметры" Центр управления безопасностью "Настройки Центра управления безопасностью" Настройки макроса "Включить все макросы" ОК "ОК. Затем вам нужно перезапустить Outlook. Для более ранних версий это в разделе Инструменты "Макрос" Безопасность….

Затем выполните действия, описанные в статье TechCenter:

• Нажмите Alt+F11, чтобы открыть VBE в Outlook.

• Перетащите mAttachmentSaver.bas файл в Project Explorer (нажмите Ctrl+R, если вы его не видите) или через File >> Import File... (Ctrl + M).

  Запустить ExecuteSaving макрос для сохранения вложений.

• Вернитесь к пользовательскому интерфейсу Outlook и нажмите Alt+F8, чтобы открыть окно макросов.

• Выбрать ExecuteSaving в списке имен, а затем нажмите кнопку " Выполнить" (не забудьте выбрать элементы Outlook перед запуском этого макроса).

• Выберите конкретную папку для сохранения вложений в диалоговом окне " Просмотр папки " и нажмите кнопку " ОК".

Пост старый, но мне кажется, что он актуален и по сей день. Вот код, который мне помог написать Chatgpt. Он сохраняет все вложения из нескольких электронных писем (pdf-файлы и т. д.), а также сохраняет и переименовывает их со случайными числами в папке вашего компьютера, которая должна называться «OLATTACHMENTS». Это позволяет сохранить до 250 изображений, поскольку Outlook зависает примерно на 2 минуты, когда я поднимаюсь на такую ​​высоту. Вот код, который необходимо поместить в Developer-Visual Basic:

      Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\OLAttachments\"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            For i = lngCount To 1 Step -1
                ' Get the file name.
                strFile = objAttachments.Item(i).FileName
                
                ' Generate a unique file name by appending a timestamp and a random number
                Dim timestamp As String
                timestamp = Format(Now, "yyyymmddhhmmss")
                Dim randomNumber As Integer
                randomNumber = Int((9999 - 1000 + 1) * Rnd + 1000)
                Dim fileExtension As String
                fileExtension = Right(strFile, Len(strFile) - InStrRev(strFile, "."))
                strFile = Left(strFile, InStrRev(strFile, ".") - 1) & "_" & timestamp & "_" & randomNumber & "." & fileExtension
                
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile
                
                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile
            Next i
        End If
    Next objMsg
    
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub