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\"
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
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