Sub SaveAtt()
    Dim oMail As MailItem
    Set oMail = Outlook.Application.ActiveExplorer.Selection(1)
 
    Dim att As Attachment
    For Each att In oMail.Attachments
                
        With att
            .SaveAsFile "c:\1\" & .FileName
           'ниже задокументирована строка коротая могла бы сработать, но не работает
           ' .Item.Move Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Черновики")
        End With
        
    Next
    Set oMail = Nothing
End Sub

Sub SaveAtt()
    Dim oMail As Outlook.MailItem, oMail_temp As Outlook.MailItem
    Dim strTempFilePath As String
    Dim att As Attachment
    Dim k As Integer, res As Integer

    On Error GoTo ErrHandler
    'выбираем текущее открытый элемент
    Set oMail = Outlook.Application.ActiveExplorer.Selection(1)
    'проверяем, что в сообщении имеются вложения
    If oMail.Attachments.Count = 0 Then MsgBox ("В данном письме отсутствуют вложения!"): Exit Sub
    'перебираем элементы вложений
    For Each att In oMail.Attachments
        'проверяем, что вложение формата msg
        k = InStrRev(att.FileName, ".")
        If (Mid(att.FileName, k + 1, Len(att.FileName) - k)) = "msg" Then
            'если это наш вариант то работаем с ним
            'запросим у пользователя нужно ли открывать письма после перемещения
            If res = 0 Then res = MsgBox("Показать вложенные письма?", 4, "Открытие вложений")
            'извлекаем его в папку Temp пользователя (C:\Users\user\AppData\Local\Temp)
            strTempFilePath = Environ("TEMP") & "\" & att.FileName
            'сохраняем файл
            att.SaveAsFile strTempFilePath
            'указываем этот элемент для работы с ним в качестве сообщения
            Set oMail_temp = Outlook.Application.CreateItemFromTemplate(strTempFilePath)
            'перемещаем его в папку Черновики почты Outlook
            oMail_temp.Move Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Черновики")
            If res = 6 Then oMail_temp.Display
            Set oMail_temp = Nothing
            'удаляем сообщения из папки Temp
            Kill strTempFilePath
        End If
    Next
    Set oMail = Nothing

  
Exit Sub
'обработчик ошибок
ErrHandler:
Select Case Err.Number
    Case 440
        MsgBox "Не выбрано почтовое сообщение!"
    Case Else
        MsgBox "Произошла ошибка " & Err.Number & vbNewLine & _
                Err.Description, vbInformation
End Select

End Sub