Save Attachment on arriving email

Question

I created an Outlook rule to save an attachment then move it to the Deleted Items folder. The code works when I highlight the arrived email in the Inbox then move the email to the Deleted Items folder.

When the new email arrives, it is saving the attachment(s) from different email in the inbox and not moving the email to the Deleted Items folder.

The Outlook rule is:

Apply this rule after the message arrives
from Sender
 and with Gift Card in the subject
 and on this computer only
run Project1.SaveAttachments

Public Sub SaveAttachments(MItem As Outlook.Mailitem)
    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 objNamespace As Outlook.NameSpace
    Dim objDestFolder As Outlook.MAPIFolder
    
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection

strFolderpath = "Y:\"

For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then

        For i = lngCount To 1 Step -1

            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
        Next i
        Set objNamespace = objOL.GetNamespace("MAPI")
        Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
                    
        objMsg.Move objDestFolder

    End If
    
Next
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing

End Sub

Possible duplicate of [Save Outlook attachment to disk](https://stackoverflow.com/questions/26225014/save-outlook-attachment-to-disk) — niton, Dec 05 '18 at 23:32
I used some of the code in the link you provided and I added more code to move the email to Deleted Items. It works when I run it manually by highlighting it but won't work when new email arrival. It saves the attachments from a different email in the Inbox folder and did not move the just arrived email to the Deleted Items folder. — Brandon168, Dec 05 '18 at 23:43
The answer to the question was to remove code related to selection. — niton, Dec 05 '18 at 23:54
You have the relevant object in MItem. Do not go looking for it in selection. — niton, Dec 06 '18 at 00:06
If the item will always have attachment then add the to your rule then clean up your code - keep it simple — 0m3r, Dec 07 '18 at 05:18

Alina Li · Answer 1 · 2018-12-06T02:52:06.173

According to my test, you could save email attachment and delete it using the below code:

Sub SaveAutoAttach()

Dim object_attachment As Outlook.attachment

Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String

Const olFolderInbox = 6

'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")

If unRead.Count = 0 Then
    MsgBox "NO Unread Email In Inbox"
Else

    some = ""
    other = ""
    saveFolder = "D:\"
    For Each m In unRead
        If m.Attachments.Count > 0 Then
            For Each object_attachment In m.Attachments
            ' Criteria to save .doc files only
                If InStr(object_attachment.DisplayName, ".doc") Then
                    object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
                End If
             Next
        End If
        m.Delete
    Next m
End Sub

For more information, please refer to this link:

Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com

Save Attachment on arriving email

1 Answers1