Descarga de adjuntos automáticamente en Outlook

Hace tiempo que no escribo nada en mi blog, aqui os dejo un trozo de codigo muy util si queremos que outlook descargue los adjuntos de los correos.

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