Public Sub Rio_Saves_XlsAttachments_Via_OutLooky()

'Author:     Roman "Rioran" Voronov
'Date:       the 19-th of November, 2014
'Feedback:   voronov_rv@mail.ru

'Refined code for saving Excel attachments from OutLook selected messages.
'Thanks Stuart for providing code basis (http://stackoverflow.com/users/267830/stuart), primary source:
'http://stackoverflow.com/questions/15531093/outlook-vba-macro-to-save-attachments-to-a-folder-and-rename-them

'Данный код позволяет сохранять вложения Excel из писем, которые были выбраны (подсвечены синим)
'в основном почтовом окне программы Microsoft Office OutLook в заранее выбранную папку

'Объявляем переменные
Dim objOL As Outlook.Application 'Для обращений к приложению OutLook
Dim objMsg As Outlook.MailItem 'Для обращений к конкретным письмам
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 'Папка для сохранения вложений

'Назначаем путь, куда будем сохранять файлы
strFolderpath = "C:\Users\rvoronov\Desktop\Тесты\"
'При ошибке прём как танки дальше
On Error Resume Next
'Вызов приложения OutLook
Set objOL = CreateObject("Outlook.Application")
'Получение коллекции выбранных объектов
Set objSelection = objOL.ActiveExplorer.Selection

'Проверяем каждое выбранное письмо на наличие вложений.
'Если есть - сохраняем вложения по пути strFolderPath
For Each objMsg In objSelection
       'Превращаем переменную в коллекцию вложений
       Set objAttachments = objMsg.Attachments
       'Подсчитываем вложения
       lngCount = objAttachments.Count
       'Если вложения есть, то...
       If lngCount > 0 Then
           'Перебираем вложения
           For i = 1 To lngCount
               'Получаем имя конкретного вложения
               strFile = objAttachments.Item(i).FileName
               'Получаем полное имя для сохраняемого файла
               strFile = strFolderpath & strFile
               'Сохраняем вложение, если оно является файлом Excel
               If strFile Like "*.xls*" Then objAttachments.Item(i).SaveAsFile strFile
           Next i
       End If
Next

'Освобождаем занятую память
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub