VBScript – Descargar Archivos Adjuntos de Varios Correos en Outlook

El siguiente Script Guarda los archivos adjuntos de una selección de correos en Outlook, no necesariamente tiene que ser en el Inbox.

También te puede interesar VBScript – Guardar Archivos Adjuntos de Correos .MSG Ya Guardados en el Disco Duro o VBScript – Guardar Archivos Adjuntos de Correos .MSG Automaticamente (Guardar adjuntos de correos adjuntos).

Instrucciones de Uso

1.- Copiamos el Codigo al Editor VBA en Outlook (Ver: Utilizar editor VBA en office).

2.- Realizamos una selección de correos con adjuntos el cual deseamos extraer o guardar en nuestro disco (No necesariamente debe ser en el Inbox puede ser cualquier carpeta).

3.- Una vez creado sin cerrar la ventana del Editor VBA presionamos la tecla F5 o damos clic en Run Sub (Ejecutar Fun)

3.- Al momento de ejecutarse nos aparecerá la ventana  para seleccionar la carpeta donde deseamos guardar los correos (.msg).

4.- Una vez seleccionada la carpeta donde se guardaran este procederá a guardar todos los adjuntos

5.- Listo, ya podemos revisar nuestra carpeta con los adjuntos.

Código

Public Sub SaveAttachmentsOfSelectedEmails()

Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection
Dim objShell As Object
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim saveFolder
Dim strSaveFldr As String
Set Exp = App.ActiveExplorer
Set Sel = Exp.Selection
Set objShell = CreateObject("Shell.Application")

Set saveFolder = objShell.BrowseForFolder(0, "Selecciona el Folder para Guardar los Adjuntos", &H400)
If saveFolder Is Nothing Then Exit Sub
strSaveFldr = saveFolder.Items.Item.Path & ""

'Loop thru each selected item in the inbox
For cnt = 1 To Sel.Count
'If the e-mail has attachments…
    If Sel.Item(cnt).Attachments.Count > 0 Then
        MsgTotal = MsgTotal + 1
        AttTotal = AttTotal + Sel.Item(cnt).Attachments.Count
          'For each attachment on the message…
          For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
            'Get the attachment
                Dim att As Attachment
                Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
               'Save it to disk
               att.SaveAsFile (strSaveFldr & att.FileName)
            Next
    End If
Next

'Clean up
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing

'Let user know we are done
Dim doneMsg As String
doneMsg = "Completed"

Exit Sub

ErrorHandler:

Dim errMsg As String
errMsg = "An error has occurred."

Dim errResult As VbMsgBoxResult
errResult = MsgBox("Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub

Este código no fue realizado por nosotros, fue encontrado en un foro publicado por un usuario el cual comenta que tampoco el lo desarrollo. (Fuente: Desconocida)