VBA Download Attachments from Outlook

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

`myMail` is `Nothing`. You need `Option Explicit` at the top of the module to flag it since it's an undeclared variable. — BigBen, Aug 03 '21 at 16:35
The items in your inbox aren't necessarily `MailItem`s so you can't use `Dim olItem As MailItem`. — BigBen, Aug 03 '21 at 16:37
VBA doesn't short-circuit, so you need a nested `If` for any other conditions besides checking if the item is a `MailItem`. The first `If` should only check the type. — BigBen, Aug 03 '21 at 16:38
Good morning, I have modified some of the annotations you have told me about but the error: Run-time error '13': Type mismatch Highlighting: Next olMail It is still present. — Alejandro González Ponce, Aug 03 '21 at 17:14
@BigBen I can't understand what you are trying to explain about the If. — Alejandro González Ponce, Aug 03 '21 at 17:20
@dbmitch Thanks for the appreciation, I have been mixing code and had not modified that part. — Alejandro González Ponce, Aug 03 '21 at 17:21
You need to nest your conditions: `If TypeName(olMail) = "MailItem" Then` (or better, `If TypeOf(olMail) Is MailItem Then`), then *another* `If`, nested: `If olMail.Subject Like "*" & "prueba" & "*" And olMail.Attachments.Count > 0 Then` — BigBen, Aug 03 '21 at 17:22
Thank you for your comments @BigBen However when I ran it again now I got another error that I had not seen until now: Run-time error '450' Wrong number of arguments or invalid property assignment — Alejandro González Ponce, Aug 03 '21 at 17:37
I update what has been done: I have deleted: fso.BuildPath from the line to create the folder. However remains the bug about: Next olMail - Run-time error '13': Type mismatch Continue the same error @BigBen — Alejandro González Ponce, Aug 03 '21 at 17:43
Thank you very much @BigBen You are a complete expert on the subject I understand, that this is a permissions error on the folder: Run time error '-2147024891 (80070005)'. I am looking for information to fix it. — Alejandro González Ponce, Aug 03 '21 at 18:13
Maybe i found the issue for my permission’s problem: https://answers.microsoft.com/en-us/msoffice/forum/all/excel-vba-run-time-error-2147024891-80070005/f29d9747-f61e-4a09-b179-b16d103e2d9b — Alejandro González Ponce, Aug 03 '21 at 18:38

score 2 · Answer 1 · answered Aug 04 '21 at 14:56

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

score 0 · Answer 2 · answered Aug 03 '21 at 21:28

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, I have just sent you a reply to give you more information about the code you provided. Thank you very much first of all! — Alejandro González Ponce, Aug 04 '21 at 13:17

score 0 · Answer 3 · answered Aug 04 '21 at 13:16

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

VBA Download Attachments from Outlook

3 Answers3