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

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

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).

Code:

---

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

---

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

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

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 _
("0000000029C6A6D99FD4274CB0141AC641282B470100942F495B65072D438EC6036ADF2CF 5A0000007AACF0C0000") '*<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