VBA Download Attachments from Outlook

Good afternoon,

I am trying to find a way to realize the following project:

When I receive an email with attachments and with a certain word in the subject, create a folder and download the attachments to that folder.

But so far I only got an error '424' - Object required on the line:

If TypeName(olMail) = "Mailterm" And myMail.Subject Like "*" & "prueba" & "*" And olMail.Attachments.Count > 0 Then

If I remove the part:

And myMail.Subject Like "*" & "prueba" & "*"

And run again that error disappears, however I get an error:

Run-time erro '13': Type mismatch

Highlighting:

Next olMail

I am not an expert on VBA but if you could help me it would be appreciated.

 Option Explicit Sub Download_Attachments() Dim ns As NameSpace Dim olFolder_Inbox As Folder Dim olMail As Object Dim olAttachment As Attachment Dim fso As Object Dim File_Saved_Folder_Path As String Dim sFolderName As String sFolderName = Format(Now, "yyyyMMdd") File_Saved_Folder_Path = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderName Set ns = GetNamespace("MAPI") Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox) Set fso = CreateObject("Scripting.FileSystemObject") For Each olMail In olFolder_Inbox.Items If TypeName(olMail) = "MailItem" Then If olMail.Subject Like "*" & "prueba" & "*" Then 'And olMail.Attachments.Count > 0 fso.CreateFolder (File_Saved_Folder_Path) For Each olAttachment In olMail.Attachments Select Case UCase(fso.GetExtensionName(olAttachment.FileName)) Case "XLSX", "XLSM" olAttachment.SaveAsFile (File_Saved_Folder_Path) End Select Next olAttachment End If End If Next olMail Set olFolder_Inbox = Nothing Set ns = Nothing Set fso = Nothing
End Sub

3 Answers

Thanks to all of you for your collaboration and help.

Finally the code has been working as follows:

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim DestinationFolderName As String
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.Filesystemobject")
sFolderName = Format(Now, "yyyyMMdd")
sMailName = Format(Now, "dd/MM/yyyy")
DestinationFolderName = "C:\Users\agonzalezp\Documents\Automatizaciones"
saveFolder = DestinationFolderName & "\" & sFolderName
subjectFilter = "NUEVA" & " " & sMailName 'REPLACE WORD SUBJECT TO FIND
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then Set outApp = New Outlook.Application OutlookOpened = True
End If
On Error GoTo Err_Control
If outApp Is Nothing Then MsgBox "Cannot start Outlook.", vbExclamation Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
If Not outFolder Is Nothing Then For Each outItem In outFolder.Items If outItem.Class = Outlook.OlObjectClass.olMail Then Set outMailItem = outItem If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter For Each outAttachment In outMailItem.Attachments If Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder) outAttachment.SaveAsFile saveFolder & " - " & outAttachment.fileName Set outAttachment = Nothing Next End If End If Next
End If SourceFileName = "C:\Users\agonzalezp\Documents\Automatizaciones\*.xlsx" DestinFileName = saveFolder FSO.MoveFile SourceFileName, DestinFileName
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then 'MsgBox Err.Description
End If
End Sub

God afternow, Alejandro,

Try this, for me work, i try use split words your code but not good working, and find this solucion, I only insert create folder, respost is on site:Save attachments to a folder and rename them David e jogold

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
sFolderName = Format(Now, "yyyyMMdd")
saveFolder = "C:\DOCUMENTOS\Outlook_Anexos" & "\" & sFolderName 'REPLACE YOUR PATCH
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
subjectFilter = ("Aplicaciones") 'REPLACE WORD SUBJECT TO FIND
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then Set outApp = New Outlook.Application OutlookOpened = True
End If
On Error GoTo Err_Control
If outApp Is Nothing Then MsgBox "Cannot start Outlook.", vbExclamation Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
If Not outFolder Is Nothing Then For Each outItem In outFolder.Items If outItem.Class = Outlook.OlObjectClass.olMail Then Set outMailItem = outItem If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter For Each outAttachment In outMailItem.Attachments If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder) outAttachment.SaveAsFile saveFolder & outAttachment.Filename Set outAttachment = Nothing Next End If End If Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then MsgBox Err.Description
End If
End Sub

Good afternoon Julio Gadioli Soares,

I have tried the code you have provided and it does work, but not as I expected.

I have managed to download the files without the permissions problem, but the files are not saved inside the folder that has been previously created, but outside.

Besides, their names have been changed.

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
sFolderName = Format(Now, "yyyyMMdd")
saveFolder = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderName
subjectFilter = ("NUEVA") 'REPLACE WORD SUBJECT TO FIND
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then Set outApp = New Outlook.Application OutlookOpened = True
End If
On Error GoTo Err_Control
If outApp Is Nothing Then MsgBox "Cannot start Outlook.", vbExclamation Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
If Not outFolder Is Nothing Then For Each outItem In outFolder.Items If outItem.Class = Outlook.OlObjectClass.olMail Then Set outMailItem = outItem If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter For Each outAttachment In outMailItem.Attachments If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder) outAttachment.SaveAsFile saveFolder & outAttachment.FileName Set outAttachment = Nothing Next End If End If Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then MsgBox Err.Description
End If
End Sub