Outlook Script

Take a look at the following link as it provides a method to do this via powershell.

http://chris.dziemborowicz.com/blog/2013/05/18/how-to-batch-extract-attachments-from-msg-files-using-powershell/

Will.

You can also do this in VBA such that it will do the action automatically for you (No separate script to run).  You will need to change some values in the code to work for your setup.  For instance I set up my test code to route specific messages to a folder in my personal files called "trash".  You will need to update that line for whatever folder you want to watch.  The code then looks for any new mail item added to that folder.  If it has a .csv attacment it saves it off.  You will need to update the path to the correct path.  

This code will need to go into the ThisOutlookSession module.

Dim WithEvents AttachmentFolderItems As Outlook.Items
Private Sub Application_Startup()
    Dim objNameSpace As Outlook.NameSpace
    Dim objNewItems As Outlook.Items
    Dim objFolders As Outlook.Folder
    
    ' Get Access to Outlook Folders
    Set objNameSpace = Outlook.GetNamespace("MAPI")
    
    ' Get the particular folder we want to watch
    Set objFolders = objNameSpace.Folders("Personal Folders").Folders("trash")
    
    ' Set up the item object so that it triggers the Item Add Event
    Set AttachmentFolderItems = objFolders.Items
    
End Sub

Private Sub AttachmentFolderItems_ItemAdd(ByVal Item As Object)
    Dim objAttachment As Outlook.Attachment
    Dim objFSO As Scripting.FileSystemObject
    Dim strNewName As String
    
    ' Use the FileSystemObject to get the extension
    Set objFSO = New Scripting.FileSystemObject
    
    ' Make sure we have a mail item before proceeding
    If Item.Class = Outlook.olMail Then
        ' Loop Through any attachments and look for a csv file
        For Each objAttachment In Item.Attachments
            Debug.Print objFSO.GetBaseName(objAttachment.FileName)
            If objFSO.GetExtensionName(objAttachment.FileName) = "csv" Then
                ' Create the new file name
                strNewName = "E:\EEtest\OOTest\" & objFSO.GetBaseName(objAttachment.FileName) & ".xls"
                objAttachment.SaveAsFile (strNewName)
            End If
        Next
    End If
    
    
End Sub

Select allOpen in new window

-Bear

Note that CSV isn't XLS, so you should not just change the file extension on save. It works, as Excel detects the real content, but you should not do that. The question is: Do you need an Excel file, or is CSV enough? E.g. it is possible to open Excel automatically with the CSV from Outlook VBA, and save as XLS(x).

Further, since you have different folders to maintain, I would use a more generic function of above:

Dim WithEvents mlItemsStaffA As Outlook.Items
Dim WithEvents mlItemsStaffB As Outlook.Items
' aso.

Private Sub Application_Startup()
    Dim objNameSpace As Outlook.NameSpace
    Dim objNewItems As Outlook.Items
    Dim objFolders As Outlook.Folder
    
    ' Get Access to Outlook Folders
    Set objNameSpace = Outlook.GetNamespace("MAPI")
    
    ' Get the particular folders we want to watch
    ' Set up the item objects so that they trigger the Item Add Event
    Set mlItemsStaffA = objNameSpace.Folders("Personal Folders").Folders("StaffA").Items
    Set mlItemsStaffB = objNameSpace.Folders("Personal Folders").Folders("StaffB").Items
    ' aso.
End Sub

Private Sub mlItemsStaffA_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, 'StaffA\')
End Sub

Private Sub mlItemsStaffB_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, 'StaffB\')
End Sub

Private Sub SaveAttachment(Item As Object, subfolder As String)
    Dim objAttachment As Outlook.Attachment
    Dim objFSO As Scripting.FileSystemObject
    Dim strNewName As String
    
    ' Use the FileSystemObject to get the extension
    Set objFSO = New Scripting.FileSystemObject
    
    ' Make sure we have a mail item before proceeding
    If Item.Class = Outlook.olMail Then
        ' Loop Through any attachments and look for a csv file
        For Each objAttachment In Item.Attachments
            Debug.Print objFSO.GetBaseName(objAttachment.FileName)
            If objFSO.GetExtensionName(objAttachment.FileName) = "csv" Then
                ' Create the new file name
                strNewName = "\\server\share\" & subfolder & objFSO.GetBaseName(objAttachment.FileName) & ".csv"
                objAttachment.SaveAsFile (strNewName)
            End If
        Next
    End If
End Sub

Select allOpen in new window

First of all, thanks for all of the suggestions and script you have post on this question. I really appreciate it...  I do have one more question... Once I open the VB For applications using "ALT-F11" .. How do I set it so I can run it as a rule on my 2010 outlook client...

Application_Startup() is called when starting Outlook (resp. the application the sub is in). To activate the code without having to restart Outlook just put the cursor somewhere into that sub, and press F5. That should execute the code, and from then on the trigger code should work automatically whenever a mail is put into one of the monitored folders.

@Qlemo - nice changes to my code.  I should have been more clear on the handling of the multiple folders.  Also, excellent point on changing the extension.

If we keep the extensions the same then I would change this code:

strNewName = "\\server\share\" & subfolder & objFSO.GetBaseName(objAttachment.FileName) & ".csv"

Select allOpen in new window

To

strNewName = "\\server\share\" & subfolder & objAttachment.FileName

Select allOpen in new window

@amstoots - You will still need your rule in outlook to move the email to your folder.  This code then watches the folder for new email and triggers the code when one arrives.  If all the attachments that will be sent to these folders are csv files or if we can assume that we can always save the attachment, then we can simplify the code even more.  The subroutine could become:

Private Sub SaveAttachment(Item As Object, subfolder As String)
    Dim objAttachment As Outlook.Attachment
    Dim strNewName As String
    
    ' Make sure we have a mail item before proceeding
    If Item.Class = Outlook.olMail Then
        ' Loop Through any attachments and look for a csv file
        For Each objAttachment In Item.Attachments
			' Create the new file name
			strNewName = "\\server\share\" & subfolder & objAttachment.FileName
			objAttachment.SaveAsFile (strNewName)
        Next
    End If
End Sub

Select allOpen in new window

As a side note, you will need to add a reference into your project to Microsoft Scripting Runtime if you keep the original code that looks for a csv file.  (We could change to the code to late binding if you like)

Also you may need to self sign your macro depending on your security settings.  This page has some old but still useful directions on how to accomplish that.  I have attached a pdf of that website just in case that link ever dies.
self-sign-macro.pdf

ok.. I am just a little unsure here... after I open up VB for applications ( ALT+F11) , how would I add the "Application_Startup() " once I open up ThisOutlookSession... First time adding this type of code to outlook



 outlook-pic.pdf

Double-click ThisOutlookSession - you should get an empty window. Then just past the code, but change the mail and file folders, of course.

Ok…Another quick question, when adding the outlook folders .. Should I add the name of the Folders where is says “Set mlItemsStaffA = objNameSpace.Folders("Personal Folders")” or should It be placed at “Folders("Region1").Items”..  Also I not for sure what I should put on the following string “call SaveAttachment(Item, 'StaffA\') ”…

Some of this assumes that the folders that you have are all personal folders in a personal .pst file.  If not, then we may need more information.

So you will need to make a copy of this line

Set mlItemsStaffA = objNameSpace.Folders("Personal Folders").Folders("StaffA").Items

Select allOpen in new window

for each folder that you have.  Replace "STaffA" with the folder name in your personal folder.  You can also rename the variable of mlItemsStaffA to something that makes more sense, but make sure you change it in all places.

Also you will need to add this sub routine for each folder (I noticed an error in this code and changed the single quotes to double quotes):

Private Sub mlItemsStaffA_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, "StaffA\")
End Sub

Select allOpen in new window

The "StaffA\" would need to be the name of the sub folder in Windows explorer for each outlook folder where the file would be saved.  This gets combined with the line "\\server\share\" to create the path.  Please make sure that the path exists or this code will fail.  We can add code to create the path if it is required.

So for example if you had three folders in Outlook for each of us (amstoots, Qlemo, Bear) you would need this code:

Private Sub Application_Startup()
    Dim objNameSpace As Outlook.NameSpace
    Dim objNewItems As Outlook.Items
    Dim objFolders As Outlook.Folder
    
    ' Get Access to Outlook Folders
    Set objNameSpace = Outlook.GetNamespace("MAPI")
    
    ' Get the particular folders we want to watch
    ' Set up the item objects so that they trigger the Item Add Event
    Set mlItemsamstoots = objNameSpace.Folders("Personal Folders").Folders("amstoots").Items
    Set mlItemsQlemo = objNameSpace.Folders("Personal Folders").Folders("Qlemo").Items
    Set mlItemsBear = objNameSpace.Folders("Personal Folders").Folders("Bear").Items
    ' aso.
End Sub

Private Sub mlItemsamstoots_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, "amstoots\")
End Sub

Private Sub mlItemsQlemo_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, "Qlemo\")
End Sub

Private Sub mlItemsBear_ItemAdd(ByVal Item As Object)
  call SaveAttachment(Item, "Bear\")
End Sub

Select allOpen in new window

Then you need to make sure that where these files are going has folders for each of us.  For example:

I hope this helps clarify some items.

-Bear

(I noticed an error in this code and changed the single quotes to double quotes)
Ooops. Well put, all that, ltlbearand3.
BTW, in Outlook VBA you do not need to use

Set objNameSpace = Outlook.GetNamespace("MAPI")

Select allOpen in new window

as Outlook.Session or Session provides exactly that. Using that, the startup code would be:

Private Sub Application_Startup()
    ' Get the particular folders we want to watch
    ' Set up the item objects so that they trigger the Item Add Event
    Set mlItemsamstoots = Sessopm.Folders("Personal Folders").Folders("amstoots").Items
    Set mlItemsQlemo = Session.Folders("Personal Folders").Folders("Qlemo").Items
    Set mlItemsBear = Session.Folders("Personal Folders").Folders("Bear").Items
    ' aso.
End Sub

Select allOpen in new window

amstoots, of course you could provide the complete path instead of a subfolder if you need to store the attachments into completely different locations, or if you like to have that complete path in the call for visibility.

Cool.  Thanks for the tip on the outlook.session object.  I was not aware of it.  [One of the great things about EE - I learn even when answering questions].

Thanks for everybody help in this script so fare..... I have learned a lot so fore... currently I ran in to a problem where is not seeing the object " The Attempted operation failed. An object could not be found" It looks to be getting stuck on the first "set Set mlItemsRegion1" for some reason... I have attached script error, screenshot of my Mailbox tree on my client, and screen shot of the debug showing the string in yellow highlight. It says it not able to find the object... am i updating it incorrectly


 

Private Sub Application_Startup()
    Dim objNameSpace As Outlook.NameSpace
    Dim objNewItems As Outlook.Items
    Dim objFolders As Outlook.Folder
    
    ' Get Access to Outlook Folders
    Set objNameSpace = Outlook.GetNamespace("MAPI")
    
    ' Get the particular folders we want to watch
    ' Set up the item objects so that they trigger the Item Add Event
    Set mlItemsRegion1 = objNameSpace.Folders("Personal Folders").Folders("Region1").Items
    Set mlItemsRegion2 = objNameSpace.Folders("Personal Folders").Folders("Region2").Items
    Set mlItemsRegion3 = objNameSpace.Folders("Personal Folders").Folders("Region3").Items
    ' aso.
End Sub

Private Sub mlItemsRegion1_ItemAdd(ByVal Item As Object)
  Call SaveAttachment(Item, "Region1\")
End Sub

Private Sub mlItemsRegion2_ItemAdd(ByVal Item As Object)
  Call SaveAttachment(Item, "Region2\")
End Sub

Private Sub mlItemsRegion3_ItemAdd(ByVal Item As Object)
  Call SaveAttachment(Item, "Region3\")
End Sub

Private Sub SaveAttachment(Item As Object, subfolder As String)
    Dim objAttachment As Outlook.Attachment
    Dim strNewName As String
    
    ' Make sure we have a mail item before proceeding
    If Item.Class = Outlook.olMail Then
        ' Loop Through any attachments and look for a csv file
        For Each objAttachment In Item.Attachments
            ' Create the new file name
            strNewName = "\\10.9.41.160\home_hlichrvaw3-ad1\mstoots\Completed Reports\EPO Reports\SQL EPOReportsLast24hrs Database portal\Region 1" & subfolder & objAttachment.FileName
            strNewName = "\\10.9.41.160\home_hlichrvaw3-ad1\mstoots\Completed Reports\EPO Reports\SQL EPOReportsLast24hrs Database portal\Region 2" & subfolder & objAttachment.FileName
            strNewName = "\\10.9.41.160\home_hlichrvaw3-ad1\mstoots\Completed Reports\EPO Reports\SQL EPOReportsLast24hrs Database portal\Region 3" & subfolder & objAttachment.FileName
            objAttachment.SaveAsFile (strNewName)
        Next
    End If
End Sub

Select allOpen in new window

Outlookscripterrormessage.jpg
outlookscriptscreenshot.jpg
EmailMailboxTree.jpg

I updated my script with what you suggested and did not get any error messages, but its not moving any of the attachments located in one of the 3 public folders. I not for sure if the script is running when close and reopen outlook client.... do I need to set up the script throw a rule for it to specified account. or do I need to wait for new mail to com in...  thanks for all of your help in advance...

Private Sub Application_Startup()
    Dim mlItemsRegion1 As Object
    Dim mlItemsRegion2 As Object
    Dim mlItemsRegion3 As Object
    
    ' Get the particular folders we want to watch
    ' Set up the item objects so that they trigger the Item Add Event
    Set mlItemsRegion1 = Outlook.Session.Folders("Mailbox - Stoots, Mike").Folders("Region1").Items
    Set mlItemsRegion2 = Outlook.Session.Folders("Mailbox - Stoots, Mike").Folders("Region2").Items
    Set mlItemsRegion3 = Outlook.Session.Folders("Mailbox - Stoots, Mike").Folders("Region3").Items
End Sub

Private Sub mlItemsRegion1_ItemAdd(ByVal item As Object)
  Call SaveAttachment(item, "Region1\")
End Sub

Private Sub mlItemsRegion2_ItemAdd(ByVal item As Object)
  Call SaveAttachment(item, "Region2\")
End Sub

Private Sub mlItemsRegion3_ItemAdd(ByVal item As Object)
  Call SaveAttachment(item, "Region3\")
End Sub

Private Sub SaveAttachment(item As Object, subfolder As String)
    Dim objAttachment As Outlook.Attachment
    Dim strNewName As String
    
    ' Make sure we have a mail item before proceeding
    If item.Class = Outlook.olMail Then
        ' Loop Through any attachments and save to network drive
        For Each objAttachment In item.Attachments
            ' Create the new file name
            strNewName = "\\10.9.41.160\home_hlichrvaw3-ad1\mstoots\Completed Reports\EPO Reports\SQL EPOReportsLast24hrs Database portal\" & subfolder & objAttachment.FileName
            objAttachment.SaveAsFile (strNewName)
            item.Move item.Parent.Folders(1)
        Next
    End If
End Sub

Select allOpen in new window

Starting Outlook is sufficient to activate the code. But it only works for new mails. If you want to test, move mails out of the folder, and copy one back into it (moving does not always trigger the ItemAdd event). The attachment contained should be saved.
If you want to be sure whether the code is really executed, locate your cursor on a line within the SaveAttachment sub containing executive code (no DIM or Comment line), press F9, and then perform above test. Execution should halt at that line. Then press F9 again (to delete the breakpoint), and F5 to continue execution.
That is the basic method to start tests.

Sorry for getting back to you guys so late.. the script works great and moves the excel files w/o any problem...... thanks...