Descargar archivos adjuntos correo

Outlook tiene la opción de descargar todos los archivos adjuntos de un correo, pero no se puede hacer de una selección de correos.

Podemos :

Sub DescargarArchivos()
    Dim adjunto As Attachment
    Dim Ruta As String
    Dim NombreArchivo As String
    Dim i As Integer
    Dim seleccion As Outlook.MailItem
    Ruta = BrowseForFolder("C:/")
    For Each seleccion In Application.ActiveExplorer.Selection
        For Each adjunto In seleccion.Attachments
            'filtramos sólo los archivos con extensión excel, este condicional se puede quitar o añadir extensiones
            If ((InStr(adjunto.DisplayName, ".xlsb") Or InStr(adjunto.DisplayName, ".xlsx") Or InStr(adjunto.DisplayName, ".xls") Or InStr(adjunto.DisplayName, ".xlsm"))) Then
                NombreArchivo = Ruta & adjunto.FileName
                adjunto.SaveAsFile NombreArchivo
            End If
        Next adjunto
    Next seleccion
End Sub
 
 
Function BrowseForFolder(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        BrowseForFolder = objFolderItem.Path & "\"
    Else
        BrowseForFolder = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Para crear un Script:

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