Solved

How do I automatically save .xlsm email attachments that come to a shared public folder with a specified subject line?

Posted on 2015-01-05
21
460 Views
Last Modified: 2015-01-11
What we need is code that will automatically save *.xlsm attachments on emails with "Specific Subject" on the subject line, then archive the email to another folder (in that shared account) so it's not in the way.  I have some code that will automatically save all *.xlsm attachments, and other code that will save all attachments on manually selected emails.  Some kind of hybrid code would be the ticket.  I am not the owner of the account, so I cannot set rules to it. Hopefully, this module could be exported to two or three other users who also have access to this account.

I'm not that experienced in VBA overall, and more of an Access VBA guy, so the Outlook aspect has me even more in the dark.  Since these Excel attachments will ultimately be imported and processed in Access anyway, the very best solution would be to run Access code that finds the incoming email attachments and imports a range directly from them.

You can see I'm not even sure what I should be shooting for.  Any pointers would be greatly appreciated!
0
Comment
Question by:Jay Williams
  • 12
  • 7
  • 2
21 Comments
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40531567
For me, it would look like this (simple version, expects the email with that subject to have 1 file attachment). I assume that it's from an automated system and you usually never get an email with that subject and NOT have an attachment.
Of course, further programming can be done to have better error handling:

Public WithEvents myItems As Outlook.Items

Public Sub Application_Startup()

	Dim myNameSpace As Outlook.NameSpace
    Set myNameSpace = Application.GetNamespace("MAPI")

    On Error GoTo notfoundFolder
    Set myItems = myNameSpace.Folders("Public Folder").Folders("public mailbox").Items  'edit!
    On Error GoTo 0

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"

End Sub


Private Sub myItems_ItemAdd(ByVal Item As Object)

    Dim moveFolder As Outlook.MAPIFolder
    If TypeName(Item) = "MailItem" Then
	
		If Item.Subject = "Specific Subject" and LCase(Right(Item.Attachments.Item(1).FileName, 5)) = ".xlsm" then 'edit subject!
				Item.Attachments.Item(1).SaveAsFile "C:\attachments\" & Item.Attachments.Item(1).FileName
			   On Error GoTo notfoundFolder
			   Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("moved xlms file") 'edit!
			   On Error GoTo 0
				
			   Item.Move moveFolder
		End if

    End If

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"
End Sub

Open in new window



Look for the "edit" comments, you need to adjust it to your own situation.
0
 

Author Comment

by:Jay Williams
ID: 40531577
Thank you my friend! I'll give it a whirl.
0
 

Author Comment

by:Jay Williams
ID: 40531622
I haven't tested this yet, but had some questions (commented).

Public WithEvents myItems As Outlook.Items 'Why is this showing red? Looks angry!

Public Sub Application_Startup()

    Dim myNameSpace As Outlook.NameSpace
    Set myNameSpace = Application.GetNamespace("MAPI")

    On Error GoTo notfoundFolder
    Set myItems = myNameSpace.Folders("XE_IPP").Folders("Inbox").Items  'Guessing on this.
    On Error GoTo 0

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"

End Sub


Private Sub myItems_ItemAdd(ByVal Item As Object)

    Dim moveFolder As Outlook.MAPIFolder
    If TypeName(Item) = "MailItem" Then
    
        If Item.Subject = "Specific Subject" And LCase(Right(Item.Attachments.Item(1).FileName, 5)) = ".xlsm" Then 'I think I got this edit right.
                Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & Item.Attachments.Item(1).FileName
               On Error GoTo notfoundFolder
               Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Requests") '"Requests" is a subfolder of the XE_IPP Inbox. Is this right?!
               On Error GoTo 0
                
               Item.Move moveFolder
        End If

    End If

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"
End Sub

Open in new window

0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40531653
Public WithEvents myItems As Outlook.Items 'Why is this showing red? Looks angry!
Not read in my Outlook. Did you use ALT+F11 in Outlook, did you put it in the ThisOutlookSession?

   Set myItems = myNameSpace.Folders("XE_IPP").Folders("Inbox").Items  'Guessing on this.

This would be correct if you are another user, and you had XE_IPP added to your Outlook (and had access to it). But I thought you said it was a Public folder?

     If Item.Subject = "Specific Subject" And LCase(Right(Item.Attachments.Item(1).FileName, 5)) = ".xlsm" Then 'I think I got this edit right.
Seems a bit weird, but if you're sure the subject is in fact "Specific Subject", who am I to argue?


Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Requests") '"Requests" is a subfolder of the XE_IPP Inbox. Is this right?!

Open in new window

This is the Request folder of the actual user with that Outlook code. If the user is in fact already XE_IPP, it is correct, it's the XE_IPP > Inbox > Requests folder
If you are logged in as John, it is in fact the John > Inbox > Requests folder
0
 

Author Comment

by:Jay Williams
ID: 40531669
OK, you're about to find out how green I am.

1. No, I didn't put it in ThisOutlookSession, I put it in it's own module, because I thought it could be more easily shared with my collaborators.  I can get it to them either way.  I know it's hard to believe, but they actually know less about this stuff than I do. :-)

2. Maybe I don't know what a public folder is. I guess it's a shared folder, not public. XE_IPP shows on my Outlook.

3. I did actually put in the right subject--after I sent it back to you.

I guess all I really have to do is put it in ThisOutlookSession instead of it's own module?
0
 
LVL 84
ID: 40531675
Are you doing this from Access? Or from Outlook?

If you're doing this from Access, you'll have to add a Reference to the Outlook library in Access. To do that, open the VBA Editor, click Tools - References, and locate the "Microsoft xx Object Library", where "xx" is the version of Outlook you're running. That should clear up the "red" line in your code.
0
 

Author Comment

by:Jay Williams
ID: 40531682
For now, I'm doing it from Outlook, but I'll keep that in mind. Thanks for your time and patience!
0
 
LVL 84
ID: 40531700
Okay - in the future, be sure to add your question to the right Zone. You included this in the Access zone only, and you really should have put it into the Office and Outlook zones.
0
 

Author Comment

by:Jay Williams
ID: 40531722
Thanks. Besides being brand new, I'm clearly Zoned Out.  I didn't even see the Office or Outlook zones.  I'll have to look out for Outlook.

You're the first one to help me on Ex Ex, and I really do appreciate your help, patience and kindness. I'll let you know how this pans out.
0
 

Author Comment

by:Jay Williams
ID: 40531771
I did put the code in ThisOutlookSession. The macro didn't run on event.
My Outlook view of XE_IPP Inbox
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Assisted Solution

by:Jay Williams
Jay Williams earned 0 total points
ID: 40531792
Here is what's in ThisOutlookSession:

Public WithEvents myItems As Outlook.Items
Public Sub Application_Startup()

    Dim myNameSpace As Outlook.NameSpace
    Set myNameSpace = Application.GetNamespace("MAPI")

    On Error GoTo notfoundFolder
    Set myItems = myNameSpace.Folders("XE_IPP").Folders("Inbox").Items
    On Error GoTo 0

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"

End Sub


Private Sub myItems_ItemAdd(ByVal Item As Object)

    Dim moveFolder As Outlook.MAPIFolder
    If TypeName(Item) = "MailItem" Then
    
        If Item.Subject = "IPP Share Request" And LCase(Right(Item.Attachments.Item(1).FileName, 5)) = ".xlsm" Then
                Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & Item.Attachments.Item(1).FileName
               On Error GoTo notfoundFolder
               Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Requests")
               On Error GoTo 0
                
               Item.Move moveFolder
        End If

    End If

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"
End Sub

Open in new window

0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40533105
The fact that you DIDN'T get a "Unable to find folder" message suggests the first part (Application_Startup()) is working.
To be sure, I'm editing some stuff, purely from a debugging standpoint:

Public WithEvents myItems As Outlook.Items
Public Sub Application_Startup()

    Dim myNameSpace As Outlook.NameSpace
    Set myNameSpace = Application.GetNamespace("MAPI")

    On Error GoTo notfoundFolder
    Set myItems = myNameSpace.Folders("XE_IPP").Folders("Inbox").Items
	msgbox "test message: counting messages " & myItems.count 'this message truly means this part of the code is correct, if the number displayed is in fact the same amount as messages in the inbox
    On Error GoTo 0

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"

End Sub


Private Sub myItems_ItemAdd(ByVal Item As Object)
	
	
	Dim moveFolder As Outlook.MAPIFolder
    If TypeName(Item) = "MailItem" Then
		
		msgbox "message arrived in  this inbox with subject: " & Item.Subject 'yay, the event DID fire! Another step in the right direction!
		msgbox "attachment extension is " & LCase(Right(Item.Attachments.Item(1).FileName, 5))
        
		If Item.Subject = "IPP Share Request" And LCase(Right(Item.Attachments.Item(1).FileName, 5)) = ".xlsm" Then
				msgbox "Inside if loop" 'hopefully this will display, if not, check the two earlier msgboxes
                Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & Item.Attachments.Item(1).FileName
               On Error GoTo notfoundFolder
               Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Requests")
               On Error GoTo 0
                
               Item.Move moveFolder
        End If

    End If

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"
End Sub

Open in new window


I'm pretty sure you can figure out what the messageboxes means, and what you should see. Please report back your findings.
For instance, the startup  should fire a message box with the message count. If not, we should focus there.
If successful though, we should wait for any message. It fires another 2 messageboxes. Good, that part works also. Now wait for a message you actually want and see if the "Inside if loop" message pops up. If so, it's only the few last lines that needs fixing.
0
 

Author Comment

by:Jay Williams
ID: 40533296
Good morning, and thank you!  Progress indeed! On start up, there was a message box that counted the files, and the count was correct, but nothing happened after that.  I did check to see that the attachments have the right extension.

Next, I sent another attachment and it did fire the message boxes, but the attachment did not save anywhere I can find it and the email did not move to the specified folder; both are "gone"--never actually saw the email or attachment.  Must be an issue with the destination folder designation?  Making sure I didn't "fat finger" something.

The two original test emails with attachments that were already in the inbox are still there untouched.  That will be an issue too; there will often be several items to be processed that come in on start up.
0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40533369
I need to know the two messages upon arrival of a message you want.
I gather you never saw the "Inside if loop" message?

Also, this code is meant  for NEW arrivals WHILE Outlook is open.
If you want it to check your current folder, I need to append some startup code as well.
0
 

Author Comment

by:Jay Williams
ID: 40533391
I did see the "Inside if loop" message, but I don't understand what it means or what it is for.  Actually, unless the messages are needed for error handling or some other purpose I don't understand, I don't need them at all.

It's great to grab the new ones when they come in, but on start up, there may be a pile of them all at once that were sent overnight.  Ultimately, the whole folder of emails with .xlsm attachments needs to be cleaned out, When and how that happens is less important.
0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40533403
As I said, I added the messages for debugging purposes and will be removed after the code is working.
Since you DID get the "Inside if loop" message, it automatically means you SHOULD:

NOT have the file in G:\XE_ECMs\IPP Sharing Development\New Requests since the code is missing a slash (if you noticed my original line was
"Item.Attachments.Item(1).SaveAsFile "C:\attachments\" & Item.Attachments.Item(1).FileName"
But the email SHOULD have been moved to YOUR OWN Inbox\Requests folder (also explained in earlier comment). because you didn't mention the "Unable to find folder" message.
0
 

Author Comment

by:Jay Williams
ID: 40533428
Gotcha. I did notice the save directory, and changed it to:

Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & Item.Attachments.Item(1).FileName

Was that wrong?

That explains why the email didn't show; I have no "Requests" folder of my own.  It is a sub folder of the (shared) XE_IPP Inbox.  These emails and attachments will be kept until the requests are processed.
0
 
LVL 35

Accepted Solution

by:
Kimputer earned 500 total points
ID: 40533477
Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & Item.Attachments.Item(1).FileName

should be

Item.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests\" & Item.Attachments.Item(1).FileName

And this

 Set moveFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Requests")

should be

Set moveFolder = Application.GetNamespace("MAPI").Folders("XE_IPP").Folders("Inbox").Folders("Requests")

or (if errors):

Dim myNameSpace As Outlook.NameSpace
Set myNameSpace = Application.GetNamespace("MAPI")
Set moveFolder = myNameSpace.Folders("XE_IPP").Folders("Inbox").Folders("Requests")
0
 

Author Comment

by:Jay Williams
ID: 40533496
It worked perfectly (you knew it would)! Thanks.  Now, how do I go back and get the other ones and take out the messages?  Am I pressing my luck? :-)
0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40533527
No, replace only the startup code:

Public Sub Application_Startup()

    Dim oMail As Outlook.MailItem
    Dim myNameSpace As Outlook.NameSpace
    Set myNameSpace = Application.GetNamespace("MAPI")

    On Error GoTo notfoundFolder
    Set myItems = myNameSpace.Folders("XE_IPP").Folders("Inbox").Items

	For Each oMail In myItems
		If TypeName(oMail) = "MailItem" Then
			If oMail.Subject = "IPP Share Request" And LCase(Right(oMail.Attachments.Item(1).FileName, 5)) = ".xlsm" Then
				   oMail.Attachments.Item(1).SaveAsFile "G:\XE_ECMs\IPP Sharing Development\New Requests" & oMail.Attachments.Item(1).FileName
				   Set moveFolder = myNameSpace.Folders("XE_IPP").Folders("Inbox").Folders("Requests")
				   oMail.Move moveFolder
			End If
		End If
    Next
		
    On Error GoTo 0

    Exit Sub

notfoundFolder:
    MsgBox "Unable to find folder"

End Sub

Open in new window


Obviously, remove or comment out the messagebox commands in the rest of the code.
0
 

Author Closing Comment

by:Jay Williams
ID: 40542867
This is an example of a very kind and qualified teacher patiently bringing a newbie along.  This was not a difficult problem for someone who knows a solution.  The biggest challenge was dragging what was needed out of me.  Kudos and thanks!
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction When developing Access applications, often we need to know whether an object exists.  This article presents a quick and reliable routine to determine if an object exists without that object being opened. If you wanted to inspect/ite…
I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

760 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

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now