Для автоматического копирования вложений из приходящих в Outlook писем в указанную папку можно воспользоваться правилом, исполняющим ниже прописанный скрипт VBA. Скрипт также модифицирует имя файла в соответствии с датой создания письма. Вариант из примера работает корректно для писем с одним вложением. Для писем с несколькими вложениями нужно изменить код в месте формирования имени файла.

  1. В Outlook откройте окно VBA. Можно воспользоваться сочетанием Alt + F11.
  2. Вставьте код, прописанный ниже, в раздел Modules. Слева найдите Modules. Если там нет раздела нет пункта Module, то создайте такой правым щелчком мыши по Modules. Или нажмите правой кнопкой по Modules, Insert -> Module.
  3. Скопируйте код в главное окно.
  4. Закройте VBA IDE.
  5. Создайте правило, вызывающее скрипт.
  6. В первом окне мастера создания нового правила выберите проверку входящих писем.
  7. В следующем окне выберите правила отбора писем.
  8. В третьем окне выберите «выполнить скрипт» (или «запустить скрипт»). Когда нажмете на подчеркнутое слов «скрипт», должен быть виден код, который был вставлен в консоль VBA.
  9. Нажмите «Завершить» и проверьте работу правила.

Код:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
saveFolder = "C:\\Test"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
For Each objAtt In itm.Attachments
'Проверяем наличие файла с таким же именем
j = " "
  For i = 1 To 1000
   If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
    j = "_" & i & "_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & objAtt.FileName
Set objAtt = Nothing
Next
End Sub

Решение проблем

Если часть созданного правила выполняется, но сам скрипт не срабатывает, то, возможно, дело в настройках безопасности Outlook 2010/2013/2016 (в Outlook 2007 и старше эта опция находится в Tools -> Macro Security). Чтобы макрос сработал:

  1. Откройте вкладку «Файл» (File), выберите настройки (Outlook Options) -> настройки безопасности (Trust Center).
  2. Нажмите на настройки центра безопасности (Trust Center Settings), затем на настройки макросов слева (Macro Settings)
  3. Выберите вариант уведомления обо всех макроса (Notifications for all macros) и нажмите OK. Это позволит выполнять макросы, но предварительно будет появляться сообщение об их запуске.

Обработка msg-вложений

Ниже пример кода, который сохраняет каждое вложение из письма в папку с названием, совпадающим с темой письма. Если вложенные файлы сами являются письмами (т.е. имеют расширение *.msg), то сохраняются только вложения из них в подпапку с названием таким же, как тема вложенного *.msg файла.
Чтобы код работал нужно включить Microsoft Scripting Runtime как описано в другой статье.

Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim objAttachments As Outlook.Attachment
Dim saveFolder As String
Dim openMsg As MailItem
 
dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
saveFolder = "C:\Test\"
If Dir(saveFolder, vbDirectory) = "" Then
  MkDir saveFolder
End If
For t = 1 To Len(itm.Subject)
  s = Mid(itm.Subject, t, 1)
  If Not LCase(s) Like "[?/\|*<>:]" Then
    sSubject = sSubject & s
  End If
Next t
 
For Each objAtt In itm.Attachments
saveFolderFull = saveFolder & sSubject
If Dir(saveFolderFull, vbDirectory) = "" Then
  MkDir saveFolderFull
End If
 
'Проверяем наличие файла с таким же именем
j = " "
  For i = 1 To 1000
   If Not Dir(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
    j = "_" & i & "_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
objAtt.SaveAsFile saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName
'Из msg файлов достаём вложения и удаляем
If LCase(Right(objAtt.FileName, 4)) = ".msg" Then
   Set openMsg = Application.CreateItemFromTemplate(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName)
   sSubject2 = ""
   For t = 1 To Len(openMsg.Subject)
    s = Mid(openMsg.Subject, t, 1)
    If Not LCase(s) Like "[?/\|*<>:]" Then
     sSubject2 = sSubject2 & s
    End If
   Next t
   If Dir(saveFolderFull & "\" & sSubject2, vbDirectory) = "" Then
     MkDir saveFolderFull & "\" & sSubject2
   End If
   'Сохраняем вложения из msg-файла
   For Each objAttachments In openMsg.Attachments
     objAttachments.SaveAsFile saveFolderFull & "\" & sSubject2 & "\" & dateOfMailItem & objAttachments.FileName
     Next
  openMsg.Close olDiscard
  Kill saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName 'Удаляем файл msg-файла
End If
Set objAtt = Nothing
Next
End Sub

Сохранение письма с вложениями на диск

Если нужно сохранить само письмо, а не только вложения, то код упрощается:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
'Public Sub saveAttachtoDisk()
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim t As Integer
Dim s As String
Dim sSubject As String
 
'Dim itm As Outlook.MailItem
'Set itm = Application.ActiveExplorer().Selection(1)

saveFolder = "C:\Test"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
 
'Удаление недопустимых символов из темы
For t = 1 To Len(itm.Subject)
  s = Mid(itm.Subject, t, 1)
  If Not LCase(s) Like "[?/\|*<>:]" Then
    sSubject = sSubject & s
  End If
Next t
 
'Проверяем наличие файла с таким же именем
j = ""
  For i = 1 To 1000
   If Not Dir(saveFolder & "\" & j & sSubject & ".msg") = "" Then
    j = "(" & i & ")_"
   Else
    Exit For
   End If
  Next i
'Конец проверки

'Сохранение вложения
itm.SaveAs (saveFolder & "\" & j & sSubject & ".msg")
 
End Sub

Полезные ссылки

  1. Rule to automatically save attachment in Outlook — другой пример
  2. MailItem Object (Outlook)

Order_macros

Теги:
 

110 Комментариев в “Автоматическое копирование вложений из писем в папку”

  1. NN:

    Добрый день!
    Макросы знаю не очень :). Но зато очень много приходит писем в экселе. Сделала все как написано. Но ничего не сохраняется и вот эта срочка красная:
    objAtt.SaveAsFile saveFolder & «\Имя » & dateOfMailItem & «.xls». Я так понимаю, что-то надо сделат с «\Имя »
    Скажите, пожалуйста, что мне надо исправить (Outlook и Excel — 10).
    И еще здесь поменяла с saveFolder = «C:\Test\» на saveFolder = «D:\Test\»

    • Здесь saveFolder — это путь к папке, куда будет сохраняться файл, а “\Имя ” & dateOfMailItem & “.xls” — название xls файла с которым его нужно сохранить.

  2. Антон:

    А как сохранять C:\mail\отправитель\data\имя вложения.xls
    оч надо плизз

  3. Николай:

    Подскажите, как сделать так, чтобы вложение сохранялось с названием темы письма (плюс расширение) в папку. А так же нельзя ли вывести кнопку на панель инструментов, которая выполняет данный скрипт?

    • Тема письма хранится в свойстве Subject. Т.е. надо заменить строку

      objAtt.SaveAsFile saveFolder & "\Имя " & dateOfMailItem & ".xls"

      на

      objAtt.SaveAsFile saveFolder & "\" & itm.Subject & ".xls"

      По поводу создания кнопки можно посмотреть вот этот материал, раздел «Кнопка на панели инструментов в Excel 2003 и старше».

  4. Владимир:

    День добрый!
    А можете подсказать? Как сохранить вложения, которые отвечают заданым критериям (например вложения типа «Прайс-001-05.09.2013.xls», где критерии слово «Прайс» и дата в названии файла) из всех непрочитаных писем. То есть макрос должен работать не постоянно, а только после нажатии кнопки анализировать непрочитаные письма и вложения. Если из какого-либо письма вложение сохраняется, письмо нужно сделать прочитаным.
    заранее спасибо!

    • Мне кажется, что проще всего будет создать правило для писем со вложением. И выполнять скрипт в этом правиле. А чтобы сохранять только файл, с определённым названием, добавьте условие типа If InStrRev(UCase(objAtt.FileName), «ПРАЙС»)

  5. Станислав:

    Добрый день! установил правило и скрипт, вложения сохраняет, но сохраненный файл открыть не могу, пишет для файла *.docx «не удается открыть файл из-за проблем с его содержимым», а для файла *.xls «действительный формат открываемого файла отличается от указываемого его расширением имени файла»
    Примечение: у меня office 2010

  6. Станислав:

    Добрый день Константин! отправляю примеры файлов. В принципе такая ситуация со всеми файлами, даже с txt.
    прописанный макрос:

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
    saveFolder = "C:\Test\"
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\привет" & dateOfMailItem & ".txt"  ' здесь расширение менял на docx, xlsx, txt
    Set objAtt = Nothing
    Next
    End Sub
    • Станислав:

      примеры послал по почте

    • Попробуйте такой код, при котором сохраняется расширение исходного файла:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
       Dim objAtt As Outlook.Attachment
       Dim saveFolder As String
       saveFolder = "C:\Test\"
       For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & objAtt.FileName
       Set objAtt = Nothing
       Next
      End Sub
      • Shoran:

        Добрый день, Константин!
        Отличная работа, воспользовался Вашим скриптом, сохраняет на Ура. Но у меня вопрос возможно как нибудь настроить так чтобы сохранял несколько файлов с конкретным расширением, в указанную папку, например «jpg»

        • Посмотрите последнюю версию кода скрипта в статье. Я сделал так, чтобы сохранялось с именем и расширением файла во вложении.
          Если нужно принудительно заменять расширение, то попробуйте строку сохранения заменить на что-то вроде этого:

          objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & Left(objAtt.FileName, InStrRev(objAtt.FileName, ".") - 1) & ".jpg"
    • Следующий код должен сохранять вложения с датой и нужным расширением:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
       Dim objAtt As Outlook.Attachment
       Dim saveFolder As String
       dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
       saveFolder = "C:\Test\"
        i = 0
       For Each objAtt In itm.Attachments
       i = i + 1
       ext = Mid(objAtt.Filename, Len(objAtt.Filename) - InStr(1, StrReverse(objAtt.Filename), ".") + 1, Len(objAtt.Filename))
       objAtt.SaveAsFile saveFolder & dateOfMailItem & "_" & i & "_" & "необходимое_имя" & ext
        Set objAtt = Nothing
       Next
      End Sub
      • Римантас:

        День добрый,
        Очень хорошая ваша работа. В английсском языке искал не один день, путался в кодах, а попробовал на русском и вот тебе на :). Дальше ломаю голову как сохранять вложения если в почте есть файл *.msg в котором тоже не одно вложение. Ни как не могу с этим справиться. Был бы очень благодарен.
        Римантас

        • Римантас, не совсем понял, что вы имеете ввиду. Код в комментарии выше работает с письмами, содержащими несколько вложений.

          • Римантас:

            Добрый день,
            Ваш скрипт паботает прекрасно — сохраняет всё под ряд и несколько вложений. Мне нужно штобы скрипт, обнаружал что вложение форматa оутлоок (расширение файла *.msg), и обнаружив открывал это вложение и из него извлекал там находяшиеся один или несколько вложений и сохранял в ту же папку как и остальные вложения.
            Спасибо.
            Хороших выходных

          • Возможно, для решения данной задачи вам будет полезен совет по ссылке:
            http://www.slipstick.com/developer/open-outlook-messages-stored-filesystem/
            Если у меня будет время, я постараюсь добавить данную возможность в код из статьи, но не обещаю.

          • Алексей:

            Переходи по ссылке без профи не разобраться
            мне тоже очень нужно
            Мне нужно штобы скрипт, обнаружал что вложение форматa оутлоок (расширение файла *.msg), и обнаружив открывал это вложение и из него извлекал там находяшиеся один или несколько вложений и сохранял в ту же папку как и остальные вложения.
            Константин пожалуйста помогите, выдел что не обещаете, если время будит напишите пожалуйста

          • Так можно сделать. Для этого нужно сохранить *.msg файл, открыть его с помощью метода Application.CreateItemFromTemplate, сохранить вложение и удалить *.msg файл.
            Кроме того нужно включить Microsoft Scripting Runtime как описано в этой статье. Ниже пример кода, который сохраняет каждое вложение в папку с названием совпадающим с темой письма, а файлы из вложенных *.msg файлов в подпапку с названием таким же, как тема вложенного *.msg файла:

            Sub saveAttachtoDisk(itm As Outlook.MailItem)
            Dim objAtt As Outlook.Attachment
            Dim objAttachments As Outlook.Attachment
            Dim saveFolder As String
            Dim openMsg As MailItem
             
            dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
            saveFolder = "C:\Test\"
            If Dir(saveFolder, vbDirectory) = "" Then
              MkDir saveFolder
            End If
            For t = 1 To Len(itm.Subject)
              s = Mid(itm.Subject, t, 1)
              If Not LCase(s) Like "[?/\|*<>:]" Then
                sSubject = sSubject & s
              End If
            Next t
             
            For Each objAtt In itm.Attachments
            saveFolderFull = saveFolder & sSubject
            If Dir(saveFolderFull, vbDirectory) = "" Then
              MkDir saveFolderFull
            End If
             
            'Проверяем наличие файла с таким же именем
            j = " "
              For i = 1 To 1000
               If Not Dir(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
                j = "_" & i & "_"
               Else
                Exit For
               End If
              Next i
            'Конец проверки
            objAtt.SaveAsFile saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName
            'Из msg файлов достаём вложения и удаляем
            If LCase(Right(objAtt.FileName, 4)) = ".msg" Then
               Set openMsg = Application.CreateItemFromTemplate(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName)
               sSubject2 = ""
               For t = 1 To Len(openMsg.Subject)
                s = Mid(openMsg.Subject, t, 1)
                If Not LCase(s) Like "[?/\|*<>:]" Then
                 sSubject2 = sSubject2 & s
                End If
               Next t
               If Dir(saveFolderFull & "\" & sSubject2, vbDirectory) = "" Then
                 MkDir saveFolderFull & "\" & sSubject2
               End If
               'Сохраняем вложения из msg-файла
               For Each objAttachments In openMsg.Attachments
                 objAttachments.SaveAsFile saveFolderFull & "\" & sSubject2 & "\" & dateOfMailItem & objAttachments.FileName
                 Next
              openMsg.Close olDiscard
              Kill saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName 'Удаляем файл msg-файла
            End If
            Set objAtt = Nothing
            Next
            End Sub
  7. Станислав:

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

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
     Dim saveFolder As String
     
     dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
     dirName = Format(Now, "mm yyyy")
     If Dir("C:\test\" & dirName, vbDirectory) = "" Then
         MkDir "C:\test\" & dirName
     End If
     saveFolder = "C:\test\" & dirName & "\"
      i = 0
     
     For Each objAtt In itm.Attachments
     
     i = i + 1
     ext = Mid(objAtt.FileName, Len(objAtt.FileName) - InStr(1, StrReverse(objAtt.FileName), ".") + 1, Len(objAtt.FileName))
      objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & i & "_" & "необходимое_имя" & ext
     
      Set objAtt = Nothing
     Next
    End Sub
  8. Виталий:

    Константин, отличный скрипт. Спасибо!
    Но если у меня письмо с вложенным текстовым файлом с одним и тем же именем приходит несколько раз в день, то какой код будет сохранять файл не только с датой, но и временем?

  9. Сергей:

    добрый день, Константин,

    а если отправителей 2 и более и для каждого исключительно своя папка для сохранения? Попробовал сосздать Module 2, но в таком случае при создании правила аутлук не видит ни одного из них. Где ошибка

    спасибо
    Сергей

  10. Влад:

    Добрый день, подскажите, пожалуйста, каким способом можно реализовать перемещение писем из папки Inbox в подпапку, писем с определенным вложением.

    Есть пример кода (ниже) но в данный момент отрабатывается не совсем корректно: в случаее если вложений в файле несколько письмо копируется несколько раз; иногда подвисает и не обрабатывает все письма. приходится перезапукать макрос повторно.

    Подскажите пожалуйста как это можно исправить?

    Sub Move_mail()
    Dim Inbox As Outlook.Folder
    Dim MailL As Outlook.MailItem
    Dim Atmt As Attachment
     
    Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
     
    For Each MailL In Inbox.Folders("test").Items
        For Each Atmt In MailL.Attachments
          If Right(Atmt.FileName, 4) = ".msg" And Left(Atmt.FileName, 4) = "Elec" Then
     
            MailL.Move Inbox.Folders("test2")
        End If
        Next
        'End If
    Next MailL
     
    End Sub
    • В вашем коде, в случае если в письме несколько вложений, то одно и то же письмо несколько раз перемещается с помощью MailL.Move Inbox.Folders(«test2»).
      Попробуйте использовать код на подобии:

      Sub Move_mail()
       Dim Inbox As Outlook.Folder
       Dim MailL As Outlook.MailItem
       Dim Atmt As Attachment
       
      Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
       
      For Each MailL In Inbox.Folders("test").Items
       i_atmt = 0
       For Each Atmt In MailL.Attachments
        If Right(Atmt.FileName, 4) = ".msg" And Left(Atmt.FileName, 4) = "Elec" Then
         i_atmt = i_atmt + 1
        End If
       Next
       If i_atmt > 0 then 
        MailL.Move Inbox.Folders("test2")
       End if
      Next MailL
       
      End Sub

      Будут перемещаться только письма со вложениями с заданной маской имени.

  11. Юрий:

    Константин, добрый день!
    У меня правило отрабатывается только, если применить его явно к уже существующим письмам. Автоматически при получении письма вложения не сохраняются… Все сделано один в один как в сабже. Почта работает по IMAP, может ли быть причина в этом?

  12. Леонид:

    Константин, подскажи, пожалуйста, как прописать так, чтобы письма брались не из inbox, а из папки, которая в inbox.
    То есть есть инбокс и в ней еще куча папок. Вот чтобы этот файл брался из одной из этих папок.

    • Леонид, это есть в одном из ответов на вопросы выше. Воспользуйтесь кодом:

      Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
      For Each MailL In Inbox.Folders("test").Items
      ...

      В данном случае папка «test» лежит в папке Inbox

  13. Sunrise:

    Большое Вам спасибо, все работает, сохраняет .zip на диск обмена 🙂 Еще бы наладить авторазархивацию zip-ов, не подкажите как можно автоматизировать этот процесс?

  14. Frend:

    Добрый день, очень полезный материал, спасибо за него!

    Но в моем случае требуется сохранять письма от конкретных адресатов в конкретные папки.
    Я сделал разброс писем по папкам в рамках самой программы, но затем приходится из этих папок перекидывать в соответствующие на общий файл сервер.
    Может Вы знаете способ как мне лучше автоматизировать данное манипуляции?
    Буду бесконечно благодарен за любую помощь!

    • Может не совсем понял, что вы имеете ввиду, но в ответ на вопрос в комментариях выше я уже упоминал, как узнать отправителя:

      For Each objAtt In itm.Attachments
        sender = objAtt.SenderName

      Соответственно для сохранения на сервере нужно прописать правильный путь в параметр saveFolder

      • Frend:

        Нужно, чтобы вложения из письма X1@mail.ru сохранялись в папку \\test\Y1\ddmmyyyy
        Вложения из письма X2@mail.ru сохранялись в папку \\test\Y2\ddmmyyyy
        и так 5-10 адресов в 5-10 папок
        и все в одном модуле!

        Я не разобрался как работает механизм нескольких отборов.

        • Можно такой код использовать:

          Public Sub saveAttachtoDisk(myItem As Outlook.MailItem)
            Const MyFolder As String = "C:\test\"
            Dim a As Outlook.Attachment
            Dim i As Long
            Dim f As String
            Dim m As String
            Dim SenderName As String
           
            i = InStrRev(myItem.SenderEmailAddress, "@")
            SenderName = Left(myItem.SenderEmailAddress, i - 1)
            If Dir(MyFolder & SenderName, vbDirectory) = "" Then
              MkDir MyFolder & SenderName & "\"
            End If
            If Dir(MyFolder & SenderName & "\" & Format(myItem.SentOn, "ddmmyyyy"), vbDirectory) = "" Then
              MkDir MyFolder & SenderName & "\" & Format(myItem.SentOn, "ddmmyyyy") & "\"
            End If
            saveFolder = MyFolder & SenderName & "\" & Format(myItem.SentOn, "ddmmyyyy") & "\"
           
            For Each a In myItem.Attachments
              With a
                f = .FileName
                i = InStrRev(f, ".")
                If i = 0 Then i = Len(f) + 1
                  j = ""
                  For k = 1 To 1000
                   If Not Dir(saveFolder & j & Left(f, i - 1) & Mid(f, i)) = "" Then
                    j = k & "_"
                   Else
                    Exit For
                   End If
                  Next k
                .SaveAsFile saveFolder & j & Left(f, i - 1) & Mid(f, i)
              End With
            Next
          End Sub
      • OtezVikentiy:

        Константин, подскажи, пожалуйста, а как допилить код, чтобы бралось из еще более вложенной папки? То есть есть такая структура папок:
        Inbox
        CAM Alarm
        1010
        1012
        и т.д.

        Вот нужно чтобы бралось из папок 1010 и 1012.

        И еще вопрос. Как прописать все так, чтобы он брал письма только от определенного отправителя?

        • Для этого можно попробовать что-то на подобии:

          Set Inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
          For Each MailL In Inbox.Folders("CAM Alarm").Folders("1010").Items

          А для того, чтобы брал только от определённого отправителя:

          For Each objAtt In itm.Attachments
            sender = objAtt.SenderName
          IF sender ="exapmle@mail.com" Then
          ...
          End if
  15. Konstantin:

    У меня офис 2010. Задача такая: от любого адресата все вложения с расширением xml сохранять допустим в папку C:\Test. Я создал правила и добавил Ваш скрипт. Но он не работает. Помогите разобраться.

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
    saveFolder = "C:\Test"
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\Имя " & dateOfMailItem & ".xls"
    Set objAtt = Nothing
    Next
    End Sub
    • У меня данный скрипт работает отлично. Возможно вам помогут рекомендации из раздела «Решение проблем».

      • Анастасия:

        «Решение проблем» прочитала, настроила всё, но не работает Макрос((( Если удаляю параметр itm As Outlook.MailItem, то выдает ошибку. Что сделать чтоб работало?

        • Сложно так сказать, нужно получить максимум информации о вашей ситуации. В частности версии программ и системы, скриншеты всех значимых окон (с макросом, с созданным правилом, с настройками разрешений для макросов в Outlook). Можете выслать все эти данные и другую информацию, которую сочтёте необходимой через форму «Заказать макрос» (кнопка в шапке сайта).

  16. Igor:

    Здравствуйте, Константин!
    Не подскажите как сохранить само письмо вместе с вложениями (если они будут) в определенной папке на компьютере (в формате .msg)? Возникла необходимость прикреплять письмо к документу в 1С, а каждый раз вручную перетаскивать письма из Outlook на компьютер неудобно.

  17. Радик:

    Здравствуйте, Константин.
    Пользуюсь вашим скриптом. Все хорошо. Но вот есть одна проблемка.
    Вот скрипт:

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
    saveFolder = "D:\Test\"
    i = 0
    For Each objAtt In itm.Attachments
    i = i + 1
    objAtt.SaveAsFile saveFolder & i & "_" & dateOfMailItem & ".xls"
    Set objAtt = Nothing
    Next
    End Sub

    Вложение сохраняется как надо, но если в этот же день приходит еще одно письмо с вложением, то ранее сохраненное вложение заменяется новым. как этого избежать? Помогите пожалуйста.

    • Добавьте в код проверку существования файла с аналогичным именем и если файл есть, то добавляйте инкремент:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
      saveFolder = "C:\Test\"
      i = 0
      For Each objAtt In itm.Attachments
      i = i + 1
      j = ""
        For k = 1 To 1000
         If Not Dir(saveFolder & i & "_" & dateOfMailItem & j & ".xls") = "" Then
          j = "_" & k
         Else
          Exit For
         End If
        Next k
      objAtt.SaveAsFile saveFolder & i & "_" & dateOfMailItem & j & ".xls"
      Set objAtt = Nothing
      Next
      End Sub
  18. Радик:

    Константин, здравствуйте.
    У меня такой вопрос. Хочу чтобы в одной и той же папке сохранялись вложения xls. Они сохраняются, но последующий файл перезаписывает предыдущий. я сделал так,чтобы было имя файла таким 1_Дата. А мне надо чтобы было: 1 файл — 1_Дата, 2_дата, 3_ Дата. Что нужно дописать?

  19. Владимир:

    Добрый день, очень полезный материал, спасибо за него!
    Константин, подскажи, пожалуйста, как решить следующую проблему.
    Ко мне приходит каждый день на почту информационное письмо, не содержащее вложений, и содержащая текст: «База на сервере успешно восстановлена». И мне надо на диск положить файл-сообщение с именем: «База поднята» + «Дата»+»Время».
    Спасибо.

    • Для начала включите Microsoft VBScript Regular Expressions 5.5 как описано в соседней статье. Вот код, который должен делать то, что вы хотите:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      'Public Sub saveAttachtoDisk()
      Dim Reg1 As RegExp
      'Dim itm As Outlook.MailItem
          'Set itm = Application.ActiveExplorer().Selection(1)
          
          saveFolder = "C:\Test\"
          UpBase = False
           If Dir(saveFolder, vbDirectory) = "" Then
               MkDir saveFolder
           End If
       
          Set Reg1 = New RegExp
          With Reg1
              .Pattern = "БАЗА\sНА\sСЕРВЕРЕ\sУСПЕШНО\sВОССТАНОВЛЕНА" '
              .IgnoreCase = True
              .Global = False 'указывает, что нужно искать только первое совпадение
          End With
       
          If Reg1.Test(itm.body) Then
            UpBase = True
          ElseIf Reg1.Test(itm.Subject) Then
            UpBase = True
          End If
       
       
          If UpBase Then
              fFileName = "База поднята_" & Format(itm.ReceivedTime, "YYYY-MM-DD_HH-mm-ss") & ".txt"
              Set fs = CreateObject("Scripting.FileSystemObject")
              fFile = saveFolder & fFileName
              Set a = fs.CreateTextFile(fFile, True)
              a.Close
          End If
      End Sub
  20. Aida:

    Здравствуйте Константин! Испробовала скрипт, работает, спасибо за работу. Но у меня не получилось добавить к названию файла имя отправителя, попробовала таким образом:

     objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & i & "_" & objAtt.FileName & "_" & objAtt.SenderName

    МОжете указать на ошибку, почему objAtt.SenderName не понимает? и у меня второй вопрос, а можно в код добавить отправку шаблона на каждое входящее письмо? Правило не позволяет приложению Outlook отправлять повторные ответы одному отправителю, от которого получено несколько сообщений. В ходе сеанса Outlook отслеживает список пользователей, которым отправлены ответы. Заранее благодарю за помощь!

    • По первому вопросу используйте код:

      objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & i & "_" & objAtt.FileName & "_" & Format(objAtt.SenderName)

      По второму вопросу пример отправки сообщения скриптом:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
      saveFolder = "C:\Test\"
      i = 0
      For Each objAtt In itm.Attachments
      i = i + 1
      j = ""
        For k = 1 To 1000
         If Not Dir(saveFolder & i & "_" & dateOfMailItem & j & ".xls") = "" Then
          j = "_" & k
         Else
          Exit For
         End If
        Next k
      objAtt.SaveAsFile saveFolder & i & "_" & dateOfMailItem & j & ".xls"
      Set objAtt = Nothing
      Call cbSendMail_Click(i & "_" & dateOfMailItem & j & ".xls")
      Next
      End Sub
       
      Sub cbSendMail_Click(FileName)
       Set OutlookApp = CreateObject("Outlook.Application")
       Set SM = OutlookApp.CreateItem(olMailItem)
       SM.To = "mail@example.ru" 'Поле "Кому"
       SM.Subject = "Сохранён файл " & FileName
       On Error Resume Next
       SM.Body = "Текст письма"
       SM.Send
       Set SM = Nothing
       Set OutlookApp = Nothing
      End Sub
  21. kulibin_slavka:

    здраствуйте Konstantin! Подскажите пожалуйста как прописать так чтобы фалы outlook сохранял в папки (создавал их если их нет) с названием темы письма

    • Например так:

      Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
      saveFolder = "C:\Test\"
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
      For t = 1 To Len(itm.Subject)
        s = Mid(itm.Subject, t, 1)
        If Not LCase(s) Like "[?/\|*<>:]" Then 'Чтобы не было недопустимых символов в имени папки
          sSubject = sSubject & s
        End If
      Next t
       
      For Each objAtt In itm.Attachments
      saveFolderFull = saveFolder & sSubject
       If Dir(saveFolderFull, vbDirectory) = "" Then
           MkDir saveFolderFull
       End If
      'Проверяем наличие файла с таким же именем
      j = " "
        For i = 1 To 1000
         If Not Dir(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
          j = "_" & i & "_"
         Else
          Exit For
         End If
        Next i
      'Конец проверки
      objAtt.SaveAsFile saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName
      Set objAtt = Nothing
      Next
      End Sub
  22. Виталий:

    Константин, суперский скрипт. Спасибо!
    А вот у меня письма с вложенным текстовым файлом с одним и тем же именем приходят около 130 штук в день (из них в 1 минуту более 10 писем бывает), то какой код будет сохранять файл не только с датой и временем может с миллисекундами?

    • Код ниже модифицированная копия одного из пользователей из комментариев. Попробуйте его. Он во-первых сохраняет файл под именем, содержащим в том числе секунды, когда пришло письмо. Во-вторых, если файл с таким именем уже есть, то добавляет последовательный индекс к имени и не затирает предыдущий.

      Public Sub saveAttachtoDisk(myItem As Outlook.MailItem)
        Const MyFolder As String = "C:\test\"
        Dim a As Outlook.Attachment
        Dim i As Long
        Dim f As String
        Dim m As String
        Dim SenderName As String
       
        SenderName = Format(myItem.SenderName)
        If Dir(MyFolder & SenderName, vbDirectory) = "" Then
          MkDir MyFolder & SenderName & "\"
        End If
        saveFolder = MyFolder & SenderName & "\"
       
        m = myItem.SenderName & Format(myItem.SentOn, "_yy_mm_dd_(hh_mm_ss)_")
        For Each a In myItem.Attachments
          With a
            f = .FileName
            i = InStrRev(f, ".")
            If i = 0 Then i = Len(f) + 1
              j = " "
              For k = 1 To 1000
               If Not Dir(saveFolder & "(" & m & .Index & ")" & j & Left(f, i - 1) & Mid(f, i)) = "" Then
                j = "_" & k & "_"
               Else
                Exit For
               End If
              Next k
            .SaveAsFile saveFolder & "(" & m & .Index & ")" & j & Left(f, i - 1) & Mid(f, i)
          End With
        Next
      End Sub
  23. Мартин:

    Огромное Вам спасибо за материал, столкнулся с такой проблемой — первый день, вчера настроил макрос и все прекрасно работало, а сегодня уже не работает (письма приходят, а файлы не сохраняются)

  24. Aleksiy:

    Что то не работает у меня код
    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, «dd.mm.yyyy»)
    saveFolder = «D:\îïà\»
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & objAtt.SenderName & dateOfMailItem & «.xls»
    Set objAtt = Nothing
    Next
    End Sub

    • Проблема в objAtt.SenderName. Сработает такой код:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
      saveFolder = "C:\\Test\"
      For Each objAtt In itm.Attachments
      SenderName = Format(itm.SenderName)
      objAtt.SaveAsFile saveFolder & SenderName & dateOfMailItem & ".xls"
      Set objAtt = Nothing
      Next
      End Sub
  25. Алексей:

    Добрый день, лузер в программировании, просто читал книжки, практики не было. Хотел создать автоматическое копирование вложений от определенных адресатов в определенную папку с изменением названия файла по имени адресата ,а само письмо удалялось вот, что получилось:

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    On Error Resume Next
    Dim myApp As Outlook.Application
    Dim myFolder As Outlook.MAPIFolder
    Dim mailitems As Items
    Dim mailmsg As MailItem
    Dim Sender$
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    DestFolder = "D:\Temp\"
    Set mailitems = Application.Session.GetDefaultFolder(olFolderInbox).Items
    Set mailmsg = mailitems.GetLast
     Sender$ = mailmsg.SenderName
    If myFolder.Items.Count > 0 Then
        For i = 1 To myFolder.Items.Count
            If myFolder.Items(i).Attachments.Count > 0 Then
                For j = 1 To myFolder.Items(i).Attachments.Count
                    myFolder.Items(i).Attachments.Item(j).SaveAsFile DestFolder & Sender$ & ".xls"
                    Next j
            mailmsg.Delete
            End If
        Next i
     
    End If
    End Sub

    Только, как то не правильно работает. Когда приходит письмо от одного из адресатов и тут же от другого происходит следующее: Вложение копируется под именем второго адресата, а удаляется письмо, которое находилось перед первым. Подскажите пожалуйста, в чем моя ошибка? Заранее благодарен.

    • Если вы вешаете выполнение скрипта на правило обработки входящих писем, то не нужно в нём каждый раз обрабатывать все письма, как в вашем коде. Используйте мой код из статьи. Я там добавил часть, которая предотвращает перезаписывание файла, если новый должен быть под таким же именем, как уже созданный.

  26. OtezVikentiy:

    Константин, приветствую еще раз, почему-то ничего не работает. У меня 10й офис. При создании правила в самом конце пишет:
    «Данное правило действительно только для приложения-клиента и будет обрабатываться только в Outlook». Сохранение не происходит даже без всяких наворотов (даже код, который указан в самом начале статьи). Что это может быть?

  27. OtezVikentiy:

    Константин, помоги, пожалуйста, есть несколько офисов… 2003, 2010 и 2013. Этот макрос работает только в 2003м. В 2010 и 2013 не работает даже в самом простом виде, сохранение из inbox. Никаких ошибок не выдает. Просто не запускается… о_О В чем может быть проблема?

    • А вы пробовали решение из раздела «Решение проблем»? Возможно в этих версиях Outlook отключены макросы. Я код использовал в 2010м, поэтому в нём всё точно должно работать.

      • OtezVikentiy:

        Ну вот я попробовал в 2003, 2010 и 2013м.
        2003 — работает
        2010 — не работает
        2013 — не работает
        Все настройки безопасности я отключил, которые описывались в разделе «решение проблем».
        Можешь что-нибудь еще посоветовать, помочь, прям ну ооооочень надо этот макрос запустить. Хотя бы на одном из офисов 2010 или 2013…

        • Макрос писался под Office 2013. Также он тестировался под Office 2016. Сложно без дополнительной информации определить причины неработоспособности скрипта в вашем случае.

      • Елена:

        Константин, помогите, пожалуйста. У меня на почту приходят счета в формате pdf. Мне нужно их сохранить как txt файл. Возможно ли в Ваш скрипт внедрить функцию сохранения pdf вложения как txt. Эта функция есть в adobe reader save as, но я никак не могу сказать в скрипте, чтобы вложение до сохранения открылось с ридером и сохранилось как текст. Может быть у Вас есть идея? заранее благодарна за помощь

        • Это крайне нетривиальная задача, и средствами только Outlook её не решить. Возможно можно как-то прописать в коде, чтобы сначала сохранялся PDF-файл, затем запускался Adobe Reader, а потом проходила команда Save As в текстовый файл… но это значительно более сложная задача и выходит далеко за рамки возможностей скрипта, описанного в статье.

  28. Алексей:

    требовалось, что бы при приходе письма с вложением, вложение падало в папку с этим очень помогли, спасибо Вам.
    использовал скрипт

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
     Dim objAtt As Outlook.Attachment
     Dim saveFolder As String
     saveFolder = "C:\Test\"
     For Each objAtt In itm.Attachments
      objAtt.SaveAsFile saveFolder & objAtt.FileName
     Set objAtt = Nothing
     Next
    End Sub

    но если присылается письмо с письмами во вложении
    то падает не конечное вложение, как нужно, а файл письма форматa оутлоок (расширение файла *.msg)

    последовал совету и пошел по ссылке:
    http://www.slipstick.com/developer/open-outlook-messages-stored-filesystem/

    так как в скриптах чайник метод попробовать так и сяк не помог аутлок ругался ерором и писал красным и желтым,
    но так и не получилось, что бы сами вложения падали, а не (*.msg)
    Люди помогите пожалуйста ведь есть, кто нибудь кто нашел с электроникой общий язык,

  29. Игорь:

    Добрый день.

    Получаю письма с заявками от клиентов с несколькими документами.
    В том числе с файлом заявкой .xls установленного образца.
    Для каждого клиента создаю новую папку в каталоге со структурой.
    Тема письма содержит слова в соответствии со структурой каталога.
    Не сам пусть, конечно же, а просто слова, соответствующие структуре.

    Подскажите, пожалуйста, возможно ли создать такой скрипт, который для каждого письма:
    — будет создавать новую папку с именем одного из слов из темы
    — складывать в эту папку все вложения этого письма

    Как я написал, заявка все время одного образца.
    Может быть, проще складывать файлы в одну папку, а потом применять другой VBA macro, который уже будет «смотреть» содержимое .xls файлов и раскладывать их по папочкам в соответствии с данными в файле, а не в теме письма?
    Спасибо!

  30. Денис:

    Добрый день.

    В аутлуке подключено 2 ящика, кроме того есть несколько подключенных PST файлов с почтой, Задача — найти во всем этом «добре» сообщения, содержащие определенную фразу и скопировать их в виде msg файла в какую-нибудь папку. Ну и все новые письма, с той-же фразой в теле письма — складывать туда-же…

    Подскажите, реально-ли это?

    • Это реально. Вот скрипт для перебора всех папок и подпапок Outlook:

      Sub SearcAllMsg()
      Dim olApp As Outlook.Application
      Dim olNS As Outlook.NameSpace
      Dim mailboxCount As Long
      Dim i As Long
      Dim folder As Outlook.MAPIFolder
      Dim oChildFolder As Outlook.MAPIFolder
      Dim oChildFolder2 As Outlook.MAPIFolder
      Dim myItems As Outlook.Items
      Dim mailmsg As Object ' Outlook.MailItem
      
      ' get local namespace
      Set olApp = Outlook.Application
      Set olNS = olApp.GetNamespace("MAPI")
       
      m = 0 'Счётчик писем
      mailboxCount = olNS.Folders.Count
       
      For i = 1 To mailboxCount
        Set folder = olNS.Folders(i)
        Set myItems = Outlook.Application.Session.GetFolderFromID(folder.EntryID).Items
       
        If myItems.Count > 0 Then   ' проверка, чтобы вообще были письма
          For Each mailmsg In myItems
            m = m + 1
            'Debug.Print mailmsg.Subject
            'Debug.Print mailmsg.body
          Next
        End If
        Debug.Print folder.Name & "(" & m & ")"
       
        For Each oChildFolder In folder.Folders
         If oChildFolder.Items.Count > 0 Then ' проверка, чтобы в папке вообще были письма
          For Each mailmsg In oChildFolder.Items
            m = m + 1
            'Debug.Print mailmsg.Subject
            'Debug.Print mailmsg.body
          Next
          Debug.Print oChildFolder.Name & "(" & m & ")"
         End If
           For Each oChildFolder2 In oChildFolder.Folders
           If oChildFolder2.Items.Count > 0 Then ' проверка, чтобы в папке вообще были письма
            For Each mailmsg In oChildFolder2.Items
              m = m + 1
              'Debug.Print mailmsg.Subject
              'Debug.Print mailmsg.body
            Next
            Debug.Print oChildFolder2.Name & "(" & m & ")"
           End If
          Next
        Next
      Next i
      'MsgBox "Писем всего: " & m
      End Sub

      Скрипт нашел тут.

      А искать фразу можно либо с помощью команды InStr, либо с помощью регулярных выражений.

  31. Ирина:

    Спасибо большое! Состряпала из всех изложенных шаблонов то, что нужно

  32. Антонсс:

    Добрый день. Константин с предложенном вами варианте нет ошибки???
    Т.к. у меня появляется красная ошибка, при добавлении

    For Each objAtt In itm.Attachments
    "C:\\mail\" & objAtt.SenderName & "\data\" & objAtt.FileName

    Или имеется ввиду что папка Отправитель уже должна существовать? ( C:\mail\отправитель\data\имя вложения.xls)

  33. Алексей:

    Добрый день.
    Есть вот такой вот код, рабочий но как-то не так, когда выполняешь его из outlook’a (применить правила…) все изумительно, но когда письмо приходит и он должен автоматически сохранить вложения, он этого не делает. При этом папка создается, что говорит о том, что скрипт запускается.

    Sub Save_Attachments1(myItem As Outlook.MailItem)
      Const MyFolder As String = "C:\test\"
      Dim a As Outlook.Attachment
      Dim i As Long
      Dim f As String
      Dim m As String
      Dim SenderName As String
     
      SenderName = Format(myItem.SenderName)
      If Dir("C:\test\" & SenderName, vbDirectory) = "" Then
        MkDir "C:\test\" & SenderName & "\"
      End If
      saveFolder = "C:\test\" & SenderName & "\"
     
      m = myItem.SenderName & Format(myItem.SentOn, "_yy_mm_dd_(hh_mm)_")
      For Each a In myItem.Attachments
        With a
          f = .FileName
          i = InStrRev(f, ".")
          If i = 0 Then i = Len(f) + 1
          .SaveAsFile saveFolder & "(" & m & .Index & ")" & Left(f, i - 1) & Mid(f, i)
        End With
      Next
    End Sub
    • Алексей, у меня Ваш скрипт отработал отлично и при использовании «Применить правило…» и при входящем сообщении. Не могу воспроизвести вашу проблему. Естественно, Outlook при этом был включен и окно VBA закрыто.

  34. Николай Петров:

    Здравствуйте. Все очень интересно и понятно, но…

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

    пытаюсь написать скрипт, который позволит сохранить конкретное выделенное письмо в загаданную папку целиком с вложениями, в формате .msg где именем файла будет тема письма.

    я создам правило обработки исходящих писем, некоторые из которых автоматически будут сохраняться в папку на локальном компьютере, доступную по сети.

    Спасибо.

    • Это не сложно. Вот пример кода:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      'Public Sub saveAttachtoDisk()
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      Dim t As Integer
      Dim s As String
      Dim sSubject As String
       
      'Dim itm As Outlook.MailItem
      'Set itm = Application.ActiveExplorer().Selection(1)
      
      saveFolder = "C:\Test"
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
       
      'Удаление недопустимых символов из темы
      For t = 1 To Len(itm.Subject)
        s = Mid(itm.Subject, t, 1)
        If Not LCase(s) Like "[?/\|*<>:]" Then
          sSubject = sSubject & s
        End If
      Next t
       
      'Сохранение вложения
      itm.SaveAs (saveFolder & "\" & sSubject & ".msg")
       
      End Sub
  35. Павел:

    Добрый день. Спасибо за тему. Подскажите как изменить макрос, так чтобы из письма с несколькими файлами выбирал необходимый по шаблону(часть имени файла)

  36. Сергей:

    Добрый день!! Спасибо большое за код!! Можете подсказать пожалуйста, почему при запуске правила скрипт отрабатывает только 1 письмо ( например 21 сенбря пришло 5 писем, а отрабатывает только 1). Код:

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
    saveFolder = "H:\26DRM\ИНФРАСТРУКТУРА\СПАРК"
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\Дата" & dateOfMailItem & ".xls"
    Set objAtt = Nothing
    Next
    End Sub
    • По коду видно, что каждое письмо, пришедшее в один день, будет сохранять вложение в один и тот же файл с названием типа «Дата24.09.2015.xls»
      Попробуйте модифицировать код так, чтобы проверялось наличие в папке файла со схожим названием и добавлялся порядковый номер. Пример:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
       
      dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
      saveFolder = "C:\\Test"
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
      For Each objAtt In itm.Attachments
      j = " "
        For i = 1 To 1000
         If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
          j = "_" & i & "_"
         Else
          Exit For
         End If
        Next i
      objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & objAtt.FileName
      Set objAtt = Nothing
      Next
      End Sub
  37. Сергей:

    Добрый день!
    Очень полезный скрипт, как раз искал что-то подобное.
    подскажите, а как возможно сохранить вложения с исходным именем и расширением?

  38. Андрей:

    Подскажите пожалуйста, как сделать чтобы после сохранения, письмо отмечалось как прочтенное?

    • Просто когда будете создавать правило обработки письма на этапе «Что следует сделать с сообщением?» выберите кроме выполнения скрипта ещё пункт «пометить как непрочитанное» (несмотря на название этот пункт непрочитанные письма помечает прочитанными).

  39. Руслан:

    Добрый день! очень полезный сайт! сам почти ничего не понимаю в скриптах, поэтому прошу помощи в моей задаче. воспользовался написанным скриптом

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
    saveFolder = "C:\\Test"
     If Dir(saveFolder, vbDirectory) = "" Then
         MkDir saveFolder
     End If
    For Each objAtt In itm.Attachments
    'Проверяем наличие файла с таким же именем
    j = " "
      For i = 1 To 1000
       If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
        j = "_" & i & "_"
       Else
        Exit For
       End If
      Next i
    'Конец проверки
    objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & objAtt.FileName
    Set objAtt = Nothing
    Next
    End Sub

    письма все сохраняются, как теперь сделать так, чтобы письма сохранялись с определенным расширением? .prl, .rar и etlr заранее спасибо!

    • Т.е. вам нужно менять исходное расширение файла? Тогда сделайте так:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
      saveFolder = "C:\\Test"
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
      For Each objAtt In itm.Attachments
      'Проверяем наличие файла с таким же именем
      j = " "
        For i = 1 To 1000
         --If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
         If Not Dir(saveFolder & "\" & dateOfMailItem & j & Left(objAtt.FileName, InStrRev(objAtt.FileName, ".") - 1) & ".prl") = "" Then
          j = "_" & i & "_"
         Else
          Exit For
         End If
        Next i
      'Конец проверки
      objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & Left(objAtt.FileName, InStrRev(objAtt.FileName, ".") - 1) & ".prl"
      Set objAtt = Nothing
      Next
      End Sub
  40. LX.:

    внесу свои 5 копеек.
    dateOfMailItem формируется из itm.CreationTime, а он не всегда отражает реальную дату. Это дата создания объекта в базе, предположим вас не было несколько дней, и вы получили почту за всю неделю — тогда все даты будут одинаковые во вложениях. ИМХО, правильнее использовать itm.ReceivedTime.
    Ну и сама сортировка по имени в таком контексте не оч. удобна, лучше сначала год\месяц\день, тогда выглядит намного лучше.

    dateOfMailItem = Format(itm.ReceivedTime, «yyyy.mm.dd»)

  41. Владимир:

    Добрый день! Очень полезный скрипт, как раз искал что-то подобное, но в скриптах я чайник. Нужно чтобы файлы сохранялись из определенной папки outlook`а, т.е. входящие\инн и сохранялся в папке с номером инн, а не даты поступления. Возможно ли это? Беда в том, что инн может быть указан где угодно в теле письмо и необходимо написать код поиска цифр состоящих из 10 или 12 символов. Константин, очень прошу помочь…

  42. Алесандр:

    Добрый день.

    Создал правило. Запустил, все заработало и начался процесс сохранения всех вложений в исходной папке C:\test. Я остановил процесс, т.к. место на диске С мало. Задал путь на переносной диск, но ничего не сохраняется. Процесс запускается, статус исполнения быстро проскакивает, но ничего не появляется в папке. Вернул исходную папку C:\test, но ниего также не происходит

  43. Алесандр:

    Еще вопрос. Можно ли сохранять вложения на сетевую папку?

    • Сейчас у меня нет возможности это проверить. Самое простое, это попробовать прописать путь к сетевой папке в качестве места сохранения и посмотреть, сработает ли:)

  44. Михаил:

    Подскажите, немного поправил Ваш код, но понимаю в этом слабо.
    Все работает, сохраняется в папке с месяцем, но если приходит письмо с таким же именем вложения, то старое заменяется на новое. Подскажите, где поправить?

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
     Dim saveFolder As String
     
     dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy_hhnnss")
     dirName = Format(Now, "mm yyyy")
     If Dir("Z:\Users\IVCHENKO Alexander\Attachments\" & dirName, vbDirectory) = "" Then
         MkDir "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName
     End If
     saveFolder = "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName & "\"
      i = 0
     
     For Each objAtt In itm.Attachments
     'Проверяем наличие файла с таким же именем
    j = " "
      For i = 1 To 1000
       If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
        j = "_" & i & "_"
       Else
        Exit For
       End If
      Next i
    'Конец проверки
     i = i + 1
     ext = Mid(objAtt.FileName, Len(objAtt.FileName) - InStr(1, StrReverse(objAtt.FileName), ".") + 1, Len(objAtt.FileName))
      objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & i & "_" & j & objAtt.FileName & ext
      Set objAtt = Nothing
     Next
    End Sub
    • Чтобы файл не заменялся в разделе «Проверяем наличие файла с таким же именем» нужно прописывать такой же путь, как и после «objAtt.SaveAsFile». Кроме того не нужно использовать инкремент с именем i, т.к. он уже используется в проверке. Если вам он нужен, то нужна другая, не используемая в иных циклах буква.
      Вот как можно поменять ваш код:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
        Dim objAtt As Outlook.Attachment
       Dim saveFolder As String
       
       dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy_hhnnss")
       dirName = Format(Now, "mm yyyy")
       If Dir("Z:\Users\IVCHENKO Alexander\Attachments\" & dirName, vbDirectory) = "" Then
           MkDir "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName
       End If
       saveFolder = "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName & "\"
        k = 0
       
       For Each objAtt In itm.Attachments
       ext = Mid(objAtt.FileName, Len(objAtt.FileName) - InStr(1, StrReverse(objAtt.FileName), ".") + 1, Len(objAtt.FileName))
       'Проверяем наличие файла с таким же именем
      j = " "
      k = k + 1
        For i = 1 To 1000
         If Not Dir(saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext) = "" Then
          j = "_" & i & "_"
         Else
          Exit For
         End If
        Next i
      'Конец проверки
        objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext
        Set objAtt = Nothing
       Next
      End Sub
  45. Михаил:

    Константин, спасибо за ответ.
    Можете подсказать как сделать
    1) чтобы вложения сохранялись в папку (MM.YYYY), а далее папка с датой (DD.MM.YYYY)
    2) чтобы вложения сохранялись в папку (MM.YYYY), а далее папка с именем отправителя, а далее как обычно в имене вложения дата и т. д.
    Заранее благодарен

    • Тогда вам нужно сначала создавать конечную папку, если она ещё не была создана, а затем сохранять туда файл.
      Для создания папки нужно заменить в скрипте эту часть:

      dirName = Format(Now, "mm yyyy") 
       If Dir("Z:\Users\IVCHENKO Alexander\Attachments\" & dirName, vbDirectory) = "" Then
           MkDir "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName
       End If
       saveFolder = "Z:\Users\IVCHENKO Alexander\Attachments\" & dirName & "\"

      На одну из этих:

          Для первого случая

          saveFolder = "Z:\Users\IVCHENKO Alexander\Attachments\" & Format(Now, "mm.yyyy")
           If Dir(saveFolder, vbDirectory) = "" Then
               MkDir saveFolder
           End If
          saveFolder = saveFolder & "\" & Format(Now, "dd.mm.yyyy")
           If Dir(saveFolder, vbDirectory) = "" Then
               MkDir saveFolder
           End If
           saveFolder = saveFolder & "\"
          Для второго случая

          saveFolder0 = "Z:\Users\IVCHENKO Alexander\Attachments\" & Format(Now, "mm.yyyy")
           If Dir(saveFolder0, vbDirectory) = "" Then
               MkDir saveFolder0
           End If
           saveFolder0 = saveFolder0 & "\"

      Для второго случая нужно также добавить после строки

      For Each objAtt In itm.Attachments

      Следующие строки

      saveFolder = saveFolder0 & objAtt.SenderName
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
       saveFolder = saveFolder & "\"
  46. Михаил:

    Благодарю!
    Константин, не подскажите, выдает ошибку по второму случаю

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
     Dim saveFolder As String
     
     dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy_hhnnss")
    saveFolder0 = "Z:\Users\LAVINCHUK Pavel\Attachments\" & Format(Now, "mm.yyyy")
     If Dir(saveFolder0, vbDirectory) = "" Then
         MkDir saveFolder0
     End If
     saveFolder0 = saveFolder0 & "\"
     
      k = 0
     
     
     For Each objAtt In itm.Attachments
     saveFolder = saveFolder0 & objAtt.SenderName (данную строку выделяет желтым)
     If Dir(saveFolder, vbDirectory) = "" Then
         MkDir saveFolder
     End If
     saveFolder = saveFolder & "\"
     
     ext = Mid(objAtt.FileName, Len(objAtt.FileName) - InStr(1, StrReverse(objAtt.FileName), ".") + 1, Len(objAtt.FileName))
     'Проверяем наличие файла с таким же именем
    j = " "
    k = k + 1
      For i = 1 To 1000
       If Not Dir(saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext) = "" Then
        j = "_" & i & "_"
       Else
        Exit For
       End If
      Next i
    'Конец проверки
    
      objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext
      Set objAtt = Nothing
     Next
    End Sub
    • Да, там небольшая ошибка была. Вот так сработает:

      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
       Dim objAtt As Outlook.Attachment
       Dim saveFolder As String
       
       dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy_hhnnss")
       saveFolder0 = "Z:\Users\LAVINCHUK Pavel\Attachments\" & Format(Now, "mm.yyyy")
       If Dir(saveFolder0, vbDirectory) = "" Then
           MkDir saveFolder0
       End If
       saveFolder0 = saveFolder0 & "\"
       
       k = 0
       
       For Each objAtt In itm.Attachments
       saveFolder = saveFolder0 & Format(itm.SenderName) 
       If Dir(saveFolder, vbDirectory) = "" Then
           MkDir saveFolder
       End If
       saveFolder = saveFolder & "\"
       
       ext = Mid(objAtt.FileName, Len(objAtt.FileName) - InStr(1, StrReverse(objAtt.FileName), ".") + 1, Len(objAtt.FileName))
       'Проверяем наличие файла с таким же именем
       j = " "
       k = k + 1
        For i = 1 To 1000
         If Not Dir(saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext) = "" Then
          j = "_" & i & "_"
         Else
          Exit For
         End If
        Next i
      'Конец проверки
      
        objAtt.SaveAsFile saveFolder & Format(Now, "DD.MM.YYYY") & "_" & k & "_" & j & objAtt.FileName & ext
        Set objAtt = Nothing
       Next
      End Sub
  47. Михаил:

    Благодарю, теперь всё работает отлично

Комментировать