Take one email with two attachments and save each attachment into a different folder

Question

I get two excel documents in one email, on a regular schedule. I have a rule set up that can save the attached documents to a single folder. For what I would like to eventually automate, I need to save the documents to different folders. So far, I can edit the names of both documents, but when ever I try some kind of compare, so that one file name goes in folder x and the other goes into folder y, either I get both in folder x, only one appears ever, or they both have poofed into oblivion.

Here is what I have so far:

Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName

Dim file As String
Dim DateFormat As String
Dim newName As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Desktop\SWR\"

Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next

 For Each objAtt In itm.Attachments


    '~> These two lines are where I run into trouble. 
    '~> Trying to change where I save the file. Only one at a time ever works.
    If InStr(objAtt.DisplayName, "Team") <> 0 Then saveFolder = saveFolder & "Productivity\"
    If InStr(objAtt.DisplayName, "Overdue") <> 0 Then saveFolder = saveFolder & "Overdue\"


    file = saveFolder & objAtt.DisplayName
    objAtt.SaveAsFile file

    Set oldName = fso.GetFile(file)

    '~> edits date to my specifications, works great
    DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ")
    '~> combines old name with date. Works great
    newName = DateFormat & objAtt.DisplayName

    oldName.Name = newName

    Set objAtt = Nothing
Next

    Set fso = Nothing
End Sub

Answer 1

Simply use if and Else command, I have also added new Dim SavePath As String so the code is not confused to where to save the the attachment.

see complete code.

Option Explicit
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim SaveFolder As String
    Dim SavePath As String
    Dim FSO As Object
    Dim oldName
    Dim file As String
    Dim DateFormat As String
    Dim newName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
    SaveFolder = enviro & "\Desktop\SWR\"

    Set FSO = CreateObject("Scripting.FileSystemObject")
'    On Error Resume Next

    For Each objAtt In itm.Attachments

        '~> These two lines are where I run into trouble.
        '~> Trying to change where I save the file. Only one at a time ever works.
'       If InStr(objAtt.DisplayName, "Team") <> 0 Then SaveFolder = SaveFolder & "Productivity\"
'       If InStr(objAtt.DisplayName, "Overdue") <> 0 Then SaveFolder = SaveFolder & "Overdue\"

        If InStr(objAtt.DisplayName, "Team.xlsx") Then
            SavePath = SaveFolder & "Productivity\"
        Else
            If InStr(objAtt.DisplayName, "Overdue.xlsx") Then
                SavePath = SaveFolder & "Overdue\"
            End If
        End If

        file = SavePath & objAtt.DisplayName

        objAtt.SaveAsFile file

        Set oldName = FSO.GetFile(file)

        '~> edits date to my specifications, works great
        DateFormat = Format(DateAdd("d", -3, oldName.DateLastModified), "mm-dd-yyyy ")
        '~> combines old name with date. Works great
        newName = DateFormat & objAtt.DisplayName

        oldName.Name = newName

    Next

    Set objAtt = Nothing
    Set FSO = Nothing
End Sub