VBA Outlook save specific attachments

Hi Experts,

I looked through the archives but didn't really see anything that matched my needs.  I would like to save and rename 2 attachments that I receive on a daily basis.  Both of the emails come from the same sender cjlek@das.com and the subject lines are ESS and Reason Codes.  I would like to save each of the email in separate folders and rename the file as it currently comes over as a series of characters and numbers.

Report 1
Subject Line ESS
Folder Path: g:\projects\schedule
Naming convention:  ess yyyy.mm.dd

Report 2
Subject Line: Reason Codes
Folder Path: g:\projects\reason codes
Naming convention:  reason codes yyyy.mm.dd

Is it possible to create VBA?
jmac001Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

omgangIT ManagerCommented:
You can do this via VBA.  Do you want it automated so the attachments are automatically saved to disk when the message arrives?  Or do you want to manually trigger the process, i.e. select the message in your Inbox and then click a ribbon command to initiate the process?
OM Gang
jmac001Author Commented:
I would like to have it done automatically when the email is received
omgangIT ManagerCommented:
Things we need to do:
1) monitor the Inbox and do something when new messages arrive
2) check each message when it arrives to determine if it's from the specified sender AND if it has one of the two specified subjects
3) if Yes on #2 then save attachment to specified location
OM Gang
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

omgangIT ManagerCommented:
I have the following to monitor the Inbox in a secondary mailbox in my Outlook.  We'll  modify to monitor your primary Inbox
OM Gang

in module ThisOutlookSession

Option Explicit

Dim WithEvents olkFolder As Outlook.Items

Private Sub Application_Startup()
On Error GoTo Err_Application_Startup

    'Change the folder path to that of the folder you want to monitor - specify display name as seen in navigation pane
    'Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    'Set olkFolder = OpenOutlookFolder("Secondary Mailbox\Inbox").Items
     Set olkFolder = Session.GetDefaultFolder(olFolderInbox).Items

Exit_Application_Startup:
    Exit Sub

Err_Application_Startup:
    MsgBox Err.Number & ", " & Err.Description, , "Error in Sub Application_Startup of VBA Document ThisOutlookSession"
    Resume Exit_Application_Startup
    
End Sub

Private Sub olkFolder_ItemAdd(ByVal Item As Object)
'this procedure will execute whenever an item is added to the folder we're monitoring
    
   'here's where we need to check the sender and subject


Exit_olkFolder_ItemAdd:
    Exit Sub

Err_olkFolder_ItemAdd:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure olkFolder_ItemAdd of VBA Document ThisOutlookSession"
    Resume Exit_olkFolder_ItemAdd

End Sub

Open in new window

omgangIT ManagerCommented:
Let's try this to validate the message item when it arrives, e.g. make sure it's from the specified sender and has the one of the subject lines we're looking for.

Private Sub olkFolder_ItemAdd(ByVal Item As Object)

On Error GoTo Err_olkFolder_ItemAdd

     Dim olAttachments As Outlook.Attachments
     Dim strSender As String, strSaveAttachAs As String, strPath As String
     Dim strDateString As String, strFileName As String

    'get sender address
     strSender = item.SenderEmailAddress

    'get reference to message attachment(s)
    olAttachments = item.Attachments

    If strSender = "cjlek@das.com" Then

        'get current date parts for file name
        strDateString = Format(Date, "yyyy") & "." & Format(Date, "mm") & "." & Format(Date, "dd")

         'message is from specified sender so lets check subject
         Select Case item.Subject
             Case "Ess"
                 strPath = "g:\projects\schedule\"
                 strFileName = "ess " & strDateString
                 'make sure there's actually an attachment present
                 If olAttachments.Count > 0 Then
                     'save attachment
                     olAttachments.Item(1).SaveAsFile strPath & strFileName
                 End If

             Case "Reason Codes"
                 strPath = "g:\projects\reason codes"
                 strFileName = "reason codes " & strDateString
                 'make sure there's actually an attachment present
                 If olAttachments.Count > 0 Then
                     'save attachment
                     olAttachments.Item(1).SaveAsFile strPath & strFileName
                 End If

             Case Else
                  'we don't do anything here
         End Select

    End If

Exit_olkFolder_ItemAdd:
    Set olAttachments = Nothing
    Exit Sub

Err_olkFolder_ItemAdd:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure olkFolder_ItemAdd of VBA Document ThisOutlookSession"
    Resume Exit_olkFolder_ItemAdd

End Sub

Open in new window

jmac001Author Commented:
HI omgang,

Couple of questions:

Do I have to change anything in the monitoring script?:

Does the second part of the code go into the "ThisOutlookSession"?  If yes I am receiving a compile error.... Ambiguous name detected: olkFolder_ItemAdd.

If no not receiving any type of error, but the files are not being saved.
omgangIT ManagerCommented:
All code should be in ThisOutlookSession.  Have you exited and restarted Outlook?  Macros are enabled when Outlook starts?

Also, please add this procedure to destroy object variable when Outlook exits.

Private Sub Application_Quit()
On Error GoTo Err_Application_Quit

    Set olkFolder = Nothing

Exit_Application_Quit:
    Exit Sub

Err_Application_Quit:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure Application_Quit of VBA Document ThisOutlookSession"
    Resume Exit_Application_Quit

End Sub

Open in new window

omgangIT ManagerCommented:
You shouldn't have to change anything in any of the code I've posted.
OM Gang
jmac001Author Commented:
OM Gang ok I did place all of the code in ThisWorkbookSession and I have exited all the way out of Outlook several times.  Each time I open the application I receive the ambiguous error
omgangIT ManagerCommented:
Please post all the code you have in ThisOutlookSession; everything from the top to the bottom.
Thanks
OM Gang
jmac001Author Commented:
I figured out the first error I did have Private Sub olkFolder_ItemAdd(ByVal Item As Object) in the code twice.

New error 91(object_variable or with block variable not set) in procedure olkfolder_ItemAdd of VBA document ThisOutlookSession

Option Explicit

Dim WithEvents olkFolder As Outlook.Items

Private Sub Application_Startup()
On Error GoTo Err_Application_Startup

    'Change the folder path to that of the folder you want to monitor - specify display name as seen in navigation pane
    'Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    'Set olkFolder = OpenOutlookFolder("Secondary Mailbox\Inbox").Items
     Set olkFolder = Session.GetDefaultFolder(olFolderInbox).Items

Exit_Application_Startup:
    Exit Sub

Err_Application_Startup:
    MsgBox Err.Number & ", " & Err.Description, , "Error in Sub Application_Startup of VBA Document ThisOutlookSession"
    Resume Exit_Application_Startup
    
End Sub



Private Sub olkFolder_ItemAdd(ByVal Item As Object)


On Error GoTo Err_olkFolder_ItemAdd

     Dim olAttachments As Outlook.Attachments
     Dim strSender As String, strSaveAttachAs As String, strPath As String
     Dim strDateString As String, strFileName As String

    'get sender address
     strSender = Item.SenderEmailAddress

    'get reference to message attachment(s)
    olAttachments = Item.Attachments

    If strSender = "cjlek@lb.com" Then

        'get current date parts for file name
        strDateString = Format(Date, "yyyy") & "." & Format(Date, "mm") & "." & Format(Date, "dd")

         'message is from specified sender so lets check subject
         Select Case Item.Subject
             Case "Electronic Store Schedule"
                 strPath = "\\SSFilePrint\GROUPSHARE\store planning\projects\reports\electonic store schedule\"
                 strFileName = "electronic store schedule " & strDateString
                 'make sure there's actually an attachment present
                 If olAttachments.Count > 0 Then
                     'save attachment
                     olAttachments.Item(1).SaveAsFile strPath & strFileName
                 End If

             Case "Partner Owned Schedule Reason Codes"
                 strPath = "\\SSFilePrint\GROUPSHARE\store planning\projects\reports\electonic store schedule - reason codes\"
                 strFileName = "reason codes " & strDateString
                 'make sure there's actually an attachment present
                 If olAttachments.Count > 0 Then
                     'save attachment
                     olAttachments.Item(1).SaveAsFile strPath & strFileName
                 End If

             Case Else
                  'we don't do anything here
         End Select

    End If

Exit_olkFolder_ItemAdd:
    Set olAttachments = Nothing
    Exit Sub

Err_olkFolder_ItemAdd:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure olkFolder_ItemAdd of VBA Document ThisOutlookSession"
    Resume Exit_olkFolder_ItemAdd

End Sub
Private Sub Application_Quit()
On Error GoTo Err_Application_Quit

    Set olkFolder = Nothing

Exit_Application_Quit:
    Exit Sub

Err_Application_Quit:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure Application_Quit of VBA Document ThisOutlookSession"
    Resume Exit_Application_Quit

End Sub

Open in new window

omgangIT ManagerCommented:
I'm not at my desk but will be back this afternoon.  I'll track that error down and get back to you.
OM Gang
omgangIT ManagerCommented:
Give this a try.  Probably best to copy my code below and replace your existing olkFolder_ItemAdd procedure as I've made more than a few changes.  This works for me.
OM Gang

Private Sub olkFolder_ItemAdd(ByVal Item As Object)
On Error GoTo Err_olkFolder_ItemAdd  
    
     Dim olAttachment As Outlook.Attachment
     Dim strSender As String, strSaveAttachAs As String, strPath As String
     Dim strDateString As String, strFileName As String

    'get sender address
     strSender = Item.SenderEmailAddress

    If strSender = "cjlek@lb.com" Then

        'get current date parts for file name
        strDateString = Format(Date, "yyyy") & "." & Format(Date, "mm") & "." & Format(Date, "dd")

         'message is from specified sender so lets check subject
         Select Case Item.Subject
             Case "Electronic Store Schedule"
                 strPath = "\\SSFilePrint\GROUPSHARE\store planning\projects\reports\electonic store schedule\"
                 strFileName = "electronic store schedule " & strDateString
                 'make sure there's actually an attachment present
                If Item.Attachments.Count > 0 Then
                     'save attachment
                    For Each olAttachment In Item.Attachments
                        olAttachment.SaveAsFile strPath & strFileName
                        Exit For
                    Next
                End If


             Case "Partner Owned Schedule Reason Codes"
                 strPath = "\\SSFilePrint\GROUPSHARE\store planning\projects\reports\electonic store schedule - reason codes\"
                 strFileName = "reason codes " & strDateString
                 'make sure there's actually an attachment present
                If Item.Attachments.Count > 0 Then
                     'save attachment
                    For Each olAttachment In Item.Attachments
                        olAttachment.SaveAsFile strPath & strFileName
                        Exit For
                    Next
                End If


             Case Else
                  'we don't do anything here
         End Select

    End If
    
    

Exit_olkFolder_ItemAdd:
    Set olAttachment = Nothing
    Exit Sub

Err_olkFolder_ItemAdd:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure olkFolder_ItemAdd of VBA Document ThisOutlookSession"
    Resume Exit_olkFolder_ItemAdd

End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
jmac001Author Commented:
Thanks!!!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Office Productivity

From novice to tech pro — start learning today.