Hay que tener dos cosas en cuenta, la primera es que este script hay que ejecutarlo con ALT+F8 y que solo descarga los adjuntos de los emails que hayamos seleccionado.
1. Abrimos outlook
2. Pulsamos ALT+F11
3. Pinchamos dos veces sobre "ThisOutlookSession"
4. Pegamos el código que pongo mas abajo
5. Guardamos el script
6. Vamos a outlook y seleccionamos varios emails con ficheros jpg adjuntos
7. Pulsamos ALT+F8 y ejecutamos SavenotdeleteAttachments
Public Sub SavenotdeleteAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim LRandomNumber As Integer
' Get the path to your My Documents folder
' ESP: Declaramos una variable con el directorio donde se descargaran los jpg
strFolderpath = "C:\imagenes\"
On Error Resume Next
' Instantiate an Outlook Application object.
' ESP: Creamos una instancia del objecto outlook
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
' ESP: Objeto donde se almacenan los emails seleccionados
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
' strFolderpath = strFolderpath
' Check each selected item for attachments.
' ESP: Revisamos todos los correos seleccionado para ver si tienen adjuntos
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' ESP: Creamos una variable con valor aleatorio para cambiar el nombre de los adjuntos que tengan
' nombres iguales
LRandomNumber = Int((3000 - 100 + 1) * Rnd + 200)
' Get the file name.
' ESP: guardamos el nombre del fichero con su extension
strFile = objAttachments.Item(i).FileName
' ESP: Modificamos el nombre del fichero para que no se sobreescriban
' si exinten varios ficheros con el mismo nombre en correos diferentes
strFile = LRandomNumber & strFile
' Combine with the path to the Temp folder.
' ESP: Combinamos todo
strFile = strFolderpath & strFile
' ESP: Reviso que el adjunto sea solo extension jpg y lo guardo.
If InStr(objAttachments.Item(i).DisplayName, ".jpg") Then
objAttachments.Item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
