Solved

Save Attachment Outlook Script - Modify to move email and mark as read

Posted on 2016-08-16
7
111 Views
Last Modified: 2016-08-18
Save Outlook Attachments based on Subject

I want to modify the code to move the emails that have the Subject = "Eriksen | Invoice #",  and mark the messages as read.




Private WithEvents objInboxItems As Items

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.GetNamespace("MAPI")
    ' instantiate Items collections for folders we want to monitor
    Set objInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    Set MyInbox = objNS.GetDefaultFolder(olFolderInbox)
    Set objNS = Nothing
End Sub

Private Sub Application_Quit()
    ' disassociate global objects declared WithEvents
    Set objInboxItems = Nothing
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    Dim olItems As Items, _
        olItem As Object, _
        olMailItem As MailItem, _
        olAttachmentItem As Attachment, _
        strInvoice As String, _
        strFileName As String


    Set olItems = objInboxItems.Restrict("[Unread] = True")
    For Each olItem In olItems
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            'Selected based on the subject you want to key on
            If InStr(1, olMailItem.Subject, "Eriksen | Invoice #", vbTextCompare) > 0 Then
                If olMailItem.Attachments.Count > 0 Then
                
                strInvoice = Right(olItem, 6)
                    For Each olAttachmentItem In olMailItem.Attachments
                strFileName = "Eriksen_Invoice_" & strInvoice
                        'Change the path on the next line to the path you want to save your attachments in
                        olAttachmentItem.SaveAsFile "H:\My Documents\3_Purchase_Card\TransactionsFY2016\Eriksen_Translations\" & strFileName & ".pdf"
                olItem.UnRead = False
                       
                    Next
                End If
            End If
        End If
    Next
End Sub

Open in new window

0
Comment
Question by:Michael Spellman
  • 3
  • 3
7 Comments
 
LVL 14

Expert Comment

by:Alexei Kuznetsov
ID: 41759484
Use olMailItem.Move() method and provide the destination folder as a parameter.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 41760435
Hi, mspellm.

If all you want to do is move the message to a folder and mark them as read, then you don't need to use this code.  You can do all of that with a rule.  My recommendation is to stick to Outlook's built-in features as much as possible and only resort to using code when your want to do something you can't do through a built-in feature.
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 41760443
Hi, mspellm.

Just saw your message to me.  I see that you want to add the following capabilities.

  • Move the email to another outlook folder or sub-folder of the Inbox
  • Print the attachment
  • Mark the email as read

That changes my earlier answer.

FIrst, create a new module in Outlook and add the following code to it.

Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Open in new window


Now, replace the code you have now with the code below.

Private WithEvents objInboxItems As Items

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.GetNamespace("MAPI")
    ' instantiate Items collections for folders we want to monitor
    Set objInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    Set MyInbox = objNS.GetDefaultFolder(olFolderInbox)
    Set objNS = Nothing
End Sub

Private Sub Application_Quit()
    ' disassociate global objects declared WithEvents
    Set objInboxItems = Nothing
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    'On the next line, edit the path to the folder you want the messages moved to after processing
    Const TARGET_FOLDER = "name@company.com\inbox\folder name"
    Dim olItems As Items, _
        olItem As Object, _
        olAttachmentItem As Attachment, _
        olkFld As Outlook.MAPIFolder, _
        strInvoice As String, _
        strFileName As String, _
        strSaveFileName As String, _
        intIdx As Integer

    Set olkFld = OpenOutlookFolder(TARGET_FOLDER)
    Set olItems = objInboxItems.Restrict("[Unread] = True")
    For intIdx = olItems.Count To 1 Step -1
        Set olItem = olItems.Item(intIdx)
        If olItem.Class = olMail Then
            'Selected based on the subject you want to key on
            If InStr(1, olItem.Subject, "Eriksen | Invoice #", vbTextCompare) > 0 Then
                If olItem.Attachments.Count > 0 Then
                    strInvoice = Right(olItem, 6)
                    For Each olAttachmentItem In olItem.Attachments
                        strFileName = "Eriksen_Invoice_" & strInvoice
                        'Change the path on the next line to the path you want to save your attachments in
                        strSaveFileName = "H:\My Documents\3_Purchase_Card\TransactionsFY2016\Eriksen_Translations\" & strFileName & ".pdf"
                        olAttachmentItem.SaveAsFile strSaveFileName
                        ShellExecute 0&, "print", strSaveFileName, 0&, 0&, 0&
                    Next
                End If
                olItem.UnRead = False
                olItem.Save
                olItem.Move olkFld
            End If
        End If
    Next
End Sub

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

1
What is SQL Server and how does it work?

The purpose of this paper is to provide you background on SQL Server. It’s your self-study guide for learning fundamentals. It includes both the history of SQL and its technical basics. Concepts and definitions will form the solid foundation of your future DBA expertise.

 

Author Comment

by:Michael Spellman
ID: 41760819
Good Morning David,

It is doing everything except for printing the attached file.  
FYI - Running on Win 7 Pro SP1 64
0
 

Author Comment

by:Michael Spellman
ID: 41760869
It is doing everything except for printing the attached file.  
 FYI - Running on Win 7 Pro SP1 64
Office 2010 Pro 32-bit
0
 

Author Closing Comment

by:Michael Spellman
ID: 41761407
Thanks David!  After I fixed my issue with Adobe Acrobat, the print function worked fine.
I had to run the installation repair.  I noticed that the print function didn't appear in the context menu when right clicking on pdf files.
This is very helpful to me.  I can't say enough about it.  Excellent!

Mike
0
 
LVL 76

Expert Comment

by:David Lee
ID: 41761758
You're welcome, Mike.  Glad I could help out.
0

Featured Post

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

825 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question