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 ThenIf 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 olMailI am not an expert on VBA but if you could help me it would be appreciated.
Option ExplicitSub Download_Attachments()Dim ns As NameSpaceDim olFolder_Inbox As FolderDim olMail As ObjectDim olAttachment As AttachmentDim fso As ObjectDim File_Saved_Folder_Path As StringDim sFolderName As StringsFolderName = Format(Now, "yyyyMMdd")File_Saved_Folder_Path = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderNameSet ns = GetNamespace("MAPI")Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox)Set fso = CreateObject("Scripting.FileSystemObject")For Each olMail In olFolder_Inbox.ItemsIf TypeName(olMail) = "MailItem" ThenIf olMail.Subject Like "*" & "prueba" & "*" Then 'And olMail.Attachments.Count > 0fso.CreateFolder (File_Saved_Folder_Path)For Each olAttachment In olMail.AttachmentsSelect Case UCase(fso.GetExtensionName(olAttachment.FileName))Case "XLSX", "XLSM"olAttachment.SaveAsFile (File_Saved_Folder_Path)End SelectNext olAttachmentEnd IfEnd IfNext olMailSet olFolder_Inbox = NothingSet ns = NothingSet fso = NothingEnd SubBest Answer
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 LibraryOn Error GoTo Err_ControlDim OutlookOpened As BooleanDim outApp As Outlook.ApplicationDim outNs As Outlook.NamespaceDim outFolder As Outlook.MAPIFolderDim outAttachment As Outlook.AttachmentDim outItem As ObjectDim DestinationFolderName As StringDim saveFolder As StringDim outMailItem As Outlook.MailItemDim inputDate As String, subjectFilter As String, sFolderName As StringDim FSO As ObjectDim SourceFileName As String, DestinFileName As StringSet 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 & "\" & sFolderNamesubjectFilter = "NUEVA" & " " & sMailName 'REPLACE WORD SUBJECT TO FINDOutlookOpened = FalseOn Error Resume NextSet outApp = GetObject(, "Outlook.Application")If Err.Number <> 0 ThenSet outApp = New Outlook.ApplicationOutlookOpened = TrueEnd IfOn Error GoTo Err_ControlIf outApp Is Nothing ThenMsgBox "Cannot start Outlook.", vbExclamationExit SubEnd IfSet outNs = outApp.GetNamespace("MAPI")Set outFolder = outNs.GetDefaultFolder(olFolderInbox)If Not outFolder Is Nothing ThenFor Each outItem In outFolder.ItemsIf outItem.Class = Outlook.OlObjectClass.olMail ThenSet outMailItem = outItemIf InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilterFor Each outAttachment In outMailItem.AttachmentsIf Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder)outAttachment.SaveAsFile saveFolder & " - " & outAttachment.fileNameSet outAttachment = NothingNextEnd IfEnd IfNextEnd IfSourceFileName = "C:\Users\agonzalezp\Documents\Automatizaciones\*.xlsx"DestinFileName = saveFolderFSO.MoveFile SourceFileName, DestinFileNameIf OutlookOpened Then outApp.QuitSet outApp = NothingErr_Control:If Err.Number <> 0 Then'MsgBox Err.DescriptionEnd IfEnd SubGod 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 LibraryOn Error GoTo Err_ControlDim OutlookOpened As BooleanDim outApp As Outlook.ApplicationDim outNs As Outlook.NamespaceDim outFolder As Outlook.MAPIFolderDim outAttachment As Outlook.attachmentDim outItem As ObjectDim saveFolder As StringDim outMailItem As Outlook.MailItemDim inputDate As String, subjectFilter As String, sFolderName As StringDim fso As ObjectSet fso = CreateObject("Scripting.FileSystemObject")sFolderName = Format(Now, "yyyyMMdd")saveFolder = "C:\DOCUMENTOS\Outlook_Anexos" & "\" & sFolderName 'REPLACE YOUR PATCHIf Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"subjectFilter = ("Aplicaciones") 'REPLACE WORD SUBJECT TO FINDOutlookOpened = FalseOn Error Resume NextSet outApp = GetObject(, "Outlook.Application")If Err.Number <> 0 ThenSet outApp = New Outlook.ApplicationOutlookOpened = TrueEnd IfOn Error GoTo Err_ControlIf outApp Is Nothing ThenMsgBox "Cannot start Outlook.", vbExclamationExit SubEnd IfSet outNs = outApp.GetNamespace("MAPI")Set outFolder = outNs.GetDefaultFolder(olFolderInbox)If Not outFolder Is Nothing ThenFor Each outItem In outFolder.ItemsIf outItem.Class = Outlook.OlObjectClass.olMail ThenSet outMailItem = outItemIf InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilterFor Each outAttachment In outMailItem.AttachmentsIf Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)outAttachment.SaveAsFile saveFolder & outAttachment.FilenameSet outAttachment = NothingNextEnd IfEnd IfNextEnd IfIf OutlookOpened Then outApp.QuitSet outApp = NothingErr_Control:If Err.Number <> 0 ThenMsgBox Err.DescriptionEnd IfEnd SubGood 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 LibraryOn Error GoTo Err_ControlDim OutlookOpened As BooleanDim outApp As Outlook.ApplicationDim outNs As Outlook.NameSpaceDim outFolder As Outlook.MAPIFolderDim outAttachment As Outlook.AttachmentDim outItem As ObjectDim saveFolder As StringDim outMailItem As Outlook.MailItemDim inputDate As String, subjectFilter As String, sFolderName As StringDim fso As ObjectSet fso = CreateObject("Scripting.FileSystemObject")sFolderName = Format(Now, "yyyyMMdd")saveFolder = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderNamesubjectFilter = ("NUEVA") 'REPLACE WORD SUBJECT TO FINDOutlookOpened = FalseOn Error Resume NextSet outApp = GetObject(, "Outlook.Application")If Err.Number <> 0 ThenSet outApp = New Outlook.ApplicationOutlookOpened = TrueEnd IfOn Error GoTo Err_ControlIf outApp Is Nothing ThenMsgBox "Cannot start Outlook.", vbExclamationExit SubEnd IfSet outNs = outApp.GetNamespace("MAPI")Set outFolder = outNs.GetDefaultFolder(olFolderInbox)If Not outFolder Is Nothing ThenFor Each outItem In outFolder.ItemsIf outItem.Class = Outlook.OlObjectClass.olMail ThenSet outMailItem = outItemIf InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilterFor Each outAttachment In outMailItem.AttachmentsIf Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)outAttachment.SaveAsFile saveFolder & outAttachment.FileNameSet outAttachment = NothingNextEnd IfEnd IfNextEnd IfIf OutlookOpened Then outApp.QuitSet outApp = NothingErr_Control:If Err.Number <> 0 ThenMsgBox Err.DescriptionEnd IfEnd Sub