For Each Incoming Email, Identify and Save Specific Attachments to Specific Folders

[Russ2012]

Thanks to anyone that can provide assistance to me in what is proving to be a very challenging requirement to resolve - Russ


Version of MS Outlook is Outlook 2010


I have a transient requirement to be able to do the following and please refer to the attached word document for a swimlane flowchart representation

For Each Email execute the following pseudo code:

IF document attachment ending in file extension ".xls" OR ".xlsm" OR ".xlsx" = TRUE THEN
IF document property [Categories] = "Supplier" THEN

Save Attachment to directory "Z:\Supplier"
ELSE

IF document property [Categories] = "Customer" THEN

Save Attachment to directory "Z:\Customer" 'Note:

ELSE

END IF

END IF
END IF


Please note that the business needs any detected attachment to be saved but not deleted from the original email. I have used the following code with some success but I have been unable to solution the requirement to determine the type of file based on reading a string identifier unique to each type in the Category property of each excel file attached


Public Sub moveAttachmentsAlpha(Item As Outlook.MailItem)
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\SCDMMailboxTest\"
On Error Resume Next
Set objMsg = Item
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

[gmayor]

This is just a variation of a macro to save attachments, which I have posted here before. The only issue is that the workbooks you want to save are categorized with 'Supplier' or 'Customer'. In order to get the category you must first save the attachment, so the following saves to the User's temporary file location in order to evaluate the categories, using a simple function to read the categories from the file. Then depending on the category the process moves the file to the required folder or a 'No Category' folder (each of which it creates if not present - assuming the Z drive is avalable). Existing files of the same name in the target folders are not overwritten, but a number is appended.

The main 'SaveAttachments' macro can be run from a script associated with a Rule, or by using one of the supplementary macros run on a folder full of messages - 'ProcessFolder', or run on an individually selected message - 'ProcessAttachment' (which you can use to test the process).


Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor www.gmayor.com
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

On Error GoTo err_Handler
Set olNS = GetNamespace("MAPI")
Set olMailFolder = olNS.PickFolder
Set olItems = olMailFolder.Items
oFrm.Show vbModeless
i = 0
For Each olMailItem In olItems
i = i + 1
PortionDone = i / olItems.Count
oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
SaveAttachments olMailItem
DoEvents
Next olMailItem
err_Handler:
Unload oFrm
Set oFrm = Nothing
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor www.gmayor.com
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strTempFldr As String: strTempFldr = Environ("Temp") & Chr(92)
Dim strSaveFldr As String

On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
strFname = olAttach.FileName
strExt = Mid(strFname, InStrRev(strFname, Chr(46)) + 1)
Select Case strExt
Case Is = "xls", "xlsx", "xlsm"
olAttach.SaveAsFile strTempFldr & strFname
Select Case GetProperties(strFname)
Case "Supplier"
strSaveFldr = "Z:\Supplier\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
Case "Customer"
strSaveFldr = "Z:\Customer\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
Case Else
strSaveFldr = "Z:\No Category\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
End Select
End Select
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFilename As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFilename) - (Len(strExtension) + 1)
strFilename = Left(strFilename, lngName)
Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor www.gmayor.com
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function GetProperties(strFilename As String) As String
'An Outlook macro by Graham Mayor www.gmayor.com
Dim sFile As Variant
Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
Dim oDir As Object: Set oDir = oShell.NameSpace(Environ("Temp") & Chr(92))
Dim i As Long
For Each sFile In oDir.Items
If sFile = strFilename Then
For i = 0 To 40
If oDir.GetDetailsOf(oDir.Items, i) = "Categories" Then
GetProperties = oDir.GetDetailsOf(sFile, i)
Exit For
End If
Next i
Exit For
End If
Next sFile
lbl_Exit:
Set oShell = Nothing
Set sFile = Nothing
Set oDir = Nothing
Exit Function
End Function

[Russ2012]

Thanks very much for this code that provides complete coverage (well almot). I'm going to insert a little bit of code from what I had been using to save the files and remove them from the incoming email and insert a link to the saved file. This is to avoid duplicatino of the attachemtns being saved due to the fact that there will be multiple users accessing the same inbox and I'll probably place the code so it triggers the routines on the Application_NewMail() event

Thanks Graham Mayor

[Russ2012]

Hi Graham,

I've modified your code to enable the processes I required but...I need to be able to run the process within a shared Outlook mailbox and I have reached the limits of my knowledge. Are you able to provide an answer please

Regards,


Russell Francis

[Russ2012]

With the aid of Graham Mayor and some other programming experts, I have been able to develop a solution that reads incoming messages from a shared mailbox by identifying the unique id as below:

Dim olfolder As Outlook.MAPIFolder
Dim olapp As Outlook.Application
Set olapp = CreateObject("Outlook.Application")
Set olfolder = olapp.GetNamespace("MAPI").GetFolderFromID _
("0000000029C6A6D99FD4274CB0141AC641282B470100942F495B65072D438EC6036ADF2CF5A 0000007AACF0C0000") '*<INSERT 'Sub GetOutlookFolderID' result>

The code provided by Graham has enabled the basis of identifying the spreadsheets that needed to be routed to the Network Drives. The WINSCP scripts are coming along well so I can route the spreadsheets to an externally hosted application for batch import. The only issue I am having trouble with is using the sentonbehalfof functionality which works for some users and not for others but this will be the subject of another thread that I'll post shorly. Thanks again