Descargar adjuntos outlook automaticamente

[skull118]

Por si alguien le sirve, tu has hecho 2 preguntas, utilice tu código y le hice una modificación para que me haga el filtro de los archivos que necesito.


Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim SubFolder As MAPIFolder
Dim strInter As String

'Abajo pongo el nombre o parte del nombre que necesito
strInter = "INTER_DIA.XLS"

GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments


'Esta linea comprueba si el archivo adjunto (Atmt), contiene el nombre o parte del nombre definido arriba (strInter), si lo contiene lo guarda.

If InStr(1, Atmt, strInter) Then
FileName = "C:\guardar\" & _
Format(Item.CreationTime, "dd mm yyyy_hh nn_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If


Next Atmt
Next Item
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\FRANCO\NICARAGUA\EXCEL." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If
End Sub