Bajar archivos adjuntos de Outlook desde Excel

[ST_]

este ejemplo lo realice como prueba de una pregunta-respuesta que un buen amigo del foro me realizo hace algunas semanas ,si no es que meses

así que despues de realizar una que otra pruebilla(ensayo y error),di con este resultado que me funciona bien para tener cerca de 697 correo(sin depurar en mi bandeja,je,je,je..mucho trabajo..comprendame ) y cerca de 535 archivos adjuntos dentro de algunos de ellos,como pueden ver,vaya que la macro si me saco de 'apuros' bueno en realidad no ya no el problema no lo tengo pero igual me sirve pra hacer un 'respaldo' de los adjuntos en un solo click

aclaro que es un ejemplo adptado de Este sitio,ya que desconozco los objetos y propiedades en Outlook,pero aun así me di mis mañas para hacerle cerca de 19 adaptaciones

Sub Guarda_Adjuntos_Outlook()
'http://www.hilpers-esp.com/485636-automatizar-adjuntos-de-outlook-con
'adaptado by ST 
Dim objOutlook As Object
Dim objMAPI As Object
Dim Item As Object
Dim Attach As Object
'Abrir Outlook
Set objOutlook = CreateObject("Outlook.Application")
'Iniciar sesión MAPI
Set objMAPI = objOutlook.GetNamespace("MAPI")
objMAPI.Logon , , False, False '<--adaptacion 1
'Obtener la carpeta de mensajes
With objMAPI.GetDefaultFolder(6) '6=olFolderInbox
'Recorrer los elementos de la carpeta
Dim J, K As Integer '<--adaptacion 2
J = 1: K = 0 '<--adaptacion 3
[O10] = .Items.Count '<--adaptacion 4
'Do While .Items.Count > 0 '<--adaptacion 5
Do While J <= .Items.Count '<--adaptacion 6
'Recuperar el primer elemento
On Error Resume Next '<----adaptacion 7
Set Item = .Items(J) '<-- adaptacion 8
[C8] = J '<-- adaptacion 9
[E8] = .Items(J) '<-- adaptacion 10
'Guardar los archivos adjuntos
For Each Attach In Item.Attachments
    Attach.SaveAsFile "C:\RespAdjuntos\" & Attach.DisplayName '<--adaptacion 11
    [D16] = Attach.DisplayName  '<-- adaptacion 12
    K = K + 1 '<-- adaptacion 13
    [N11] = K '<-- adaptacion 14
Next
J = J + 1 '<--adaptacion 15
'Borrar el correo'<--adaptacion 16
'Item.Delete '<--adaptacion 17
Loop
End With
[N12] = GetFiles("C:\RespAdjuntos\*.*") '<--adaptacion 18
'Cerrar sesión
objMAPI.Logoff
'Destruir referencias
Set objOutlook = Nothing
Set Item = Nothing
Set Attach = Nothing
Set objMAPI = Nothing
MsgBox "Adjuntos guardados", vbInformation, "Informe de acciones" '<--adaptacion 19
End Sub

Private Function GetFiles(ByVal folder As String) As Long
'http://www.hilpers-esp.com/477928-contar-archivos
    Dim file As String
    Dim n As Long
' Obtenemos el primer archivo
    file = Dir(folder, vbArchive + vbHidden + _
    vbNormal + vbReadOnly + vbSystem)
        Do While file <> ""
        ' Contador de archivos
            n = n + 1
        ' Obtenemos los siguientes archivos
            file = Dir
        Loop
' Devolvemos el número de archivos
GetFiles = n
End Function

de cualquier forma dejo el ejemplo para descargar y probar

perdon..se me olvido comentar que el requisito previo para que funcione adecuadamente la macro es que exista la carpeta "RespAdjuntos" en "C:\" es decir la ruta "C:\RespAdjuntos\"

Guardar adjuntos de Outlook_ST.zip

[Georgy]

Hola ST

Excelente aporte. Nadie sabe quizas algun día la use. El conocimento nunca sobra.

[ST_]

....Excelente aporte......

...!! significa que lo probaste y te funcionó ??

bien..la idea no es solo compartirlocon ustedes y con mi amigo Daniel que me preguto sobre el tema,si no que como 'noveles' en el asunto (Daniel y Yo),puedan hacer sus aportaciones que nos enriquezcan a todos aquellos que muy de lejos(enviar un correo con adjunto,cuando mucho) hemos tocado el tema excel-outlook.

[dacevedod]

Se puede extraer una archivos de una carpeta especifica de Outlook?