Save attachments from specified subject in specific Inbox subfolder

Question

I would like to setup a VBA to automatically download attachments from unread emails with the subject "Shipment MTD" in the sub-folder Inbox\Reports and save them to the following folder C:\My Documents\Daily Shipments

Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    Dim dtDate As Date
    Dim sName As String

    ' Get the path to your My Documents folder
    strFolderpath = "C:\My Documents\Daily Shipment"
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("Reports")
    Set myTasks = Fldr.Items

    ' Select unread items with required subject line
    Set resultItems = myTasks.Restrict("[UnRead] = False AND [Subject] = ""Shipment MTD""")

    ' Get the collection of selected objects.
    Set objSelection = resultItems

    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\Daily Shipment\"

    ' Select attachements in messsage
    Set objAttachments = objMsg.Attachments

    ' Check each selected item for attachments.

    For Each resultItems In myTasks
        lngCount = objAttachments.Count

        If lngCount > 0 Then

            dtDate = objMsg.SentOn
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" 'include DTS

            For i = lngCount To 1 Step -1

                ' Get the file name.
                strFile = sName & objAttachments.Item(i).FileName
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile

                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile

            Next i
        End If

    Next

ExitSub:

        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
End Sub

I want to select only the unread emails in the reports folder. It seems that VBA is not selecting this correctly.

Is there a specific reason that you are you trying to do this through excel-vba instead of directly from outlook-vba? (Also, you have forgotten to declare a lot of variables, such as MyTasks or olApp) — Chronocidal
How many Items are in resultItems? (Try MsgBox resultItems.Count) Your DASL query will be looking for subjects that exactly match "Shipment MTD", no "Re: Shipment MTD" or "Shipment MTD - 2018-01-01" allowed. — Chronocidal
Hi chronocidal, actually it’s in outlook-vba. In terms of the subject, I think it’s alright because the daily emails contain exactly the same subject. I’ll look at declaring all my variables again. — kaiallard
Re variables: Always use Option Explicit - you can turn it on by default from the options menu. :) — Chronocidal

0m3r 0m3r · Accepted Answer · 2018-04-09T06:58:06

Here is better filter that will filter by Subject, unread and items with attachments only, also your code has lots errors

Here is after cleanup, short and simple

Option Explicit
Public Sub SaveAttachments()
    ' Get the path to your My Documents folder
    Dim strFolderpath As String
        strFolderpath = "C:\Documents\Temp\"

    ' Instantiate an Outlook Application object.
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")
    Dim Fldr As Outlook.Folder
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("Flash Orders")

    Dim Filter As String
        Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
                           Chr(34) & " Like '%Shipment MTD%' AND " & _
                           Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                           Chr(34) & "=1 AND " & _
                           Chr(34) & "urn:schemas:httpmail:read" & _
                           Chr(34) & "=0"

    Dim myTasks As Outlook.Items
    Set myTasks = Fldr.Items.Restrict(Filter)

    Dim i As Long
    Dim objMsg As Outlook.MailItem 'Object

    For i = myTasks.Count To 1 Step -1
        If myTasks(i).Class = olMail Then
            Set objMsg = myTasks(i)

            Dim dtDate As Date
                dtDate = objMsg.SentOn
            Dim sName As String
                sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
                        Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem)

            Dim strFile As String
            Dim objAttachment As Outlook.Attachment
            For Each objAttachment In objMsg.Attachments
                ' Get the file name.
                strFile = strFolderpath & sName & "-" & objAttachment.FileName
                Debug.Print strFile
                ' Save the attachment as a file.
                objAttachment.SaveAsFile strFile
            Next
        End If
    Next i

End Sub

Save attachments from specified subject in specific Inbox subfolder

1 Answers