VBA Download Attachments from Outlook - vba

Question

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

Answer 1

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

Answer 2

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

Answer 3

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