Bulk Attachment Save with File Name Based on Subject

Question

I'm very new to programing and have been working with VBA (macro recorder) in Excel.

I will be sent about 500 bulk expenditure, revenue, budget reports on a monthly basis which all have their own unique subject line. An example subject line will be "Report 001" and I want to save the Excel attachment as "Project A 2016". If subject is "Report 002" then save the file as "Project B 2015" etc.

Another thought is would referencing an Excel table utilizing a vLookup for saving the file name be appropriate. Again this all new and I'm lacking the direction.

** Update ** 7/7/2017

The code, working to my needs, is posted below. The code is based on http://www.fontstuff.com/outlook/oltut01pfv.htm.

The code takes emails with specific subject and saves the files with a specific naming convention on my desktop.

Can I make my code more efficient? Since this is a block of 4 email subjects and I could have upwards of 500 coming in a batch, could a loop be created that referenced a csv file or something?

Sub GetAttachments6()

' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("AutoRunReport") ' Enter correct subfolder name.
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the AutoRunReport folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 36) = "Monthly Auto Gen Report PY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2015 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 37) = "Monthly Auto Gen Report PPY LD01_0210" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2014 0290000210 ADMIN" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If

            If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0215" Then
                FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000215 HR" & ".pdf"
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item


' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Desktop\TestTestTest folder." _
        & vbCrLf & vbCrLf & "Would you like to view the files now?" _
        , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,C:\Users\drowan\Desktop\TestTestTest\", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

It is not completely clear to me what you are trying to do. Do you want to group together attachments came in messages with the same subject? If so, you can write code to iterate through your e-mail collection and save its attachments, not all in the same folder, but in subfolders named after the e-mail subject. You will have to dodge some traps like possible characters in subject that are not valid in a folder name, but it might serve your needs. — VBobCat, Jul 04 '17 at 01:57
hi, you may want to refer to https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them and edit it to use the `.subject` property to determine file name etc. — AiRiFiEd, Jul 04 '17 at 05:57
Thank you for the posts, they definitely helped, I was having problem with the basic structure and syntax of VBA. — mrdj007, Jul 08 '17 at 05:30
i have posted some code for you to try. would you please post more of the "subject line" --- "saved filename" relationships, so that i can refine the formula for translating between the two — jsotola, Jul 11 '17 at 21:33

jsotola · Answer 1 · 2017-07-11T21:40:55.410

here is some code that parses the attachment name and calculates a file name from that

it works for the four examples given

Sub GetAttachments6()

        ' This Outlook macro checks a named subfolder in the Outlook Inbox
        ' (here the "Sales Reports" folder) for messages with attached
        ' files of a specific type (here file with an "xls" extension)
        ' and saves them to disk. Saved files are timestamped. The user
        ' can choose to view the saved files in Windows Explorer.
        ' NOTE: make sure the specified subfolder and save folder exist
        ' before running the macro.

    On Error GoTo SaveAttachmentsToFolder_err

    Dim folderItems As Items
    Set folderItems = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("AutoRunReport").Items

    If folderItems.Count = 0 Then                                     ' Check subfolder for messages and exit of none found
        MsgBox "There are no messages in the AutoRunReport folder.", _
        vbInformation, "Nothing Found"
        GoTo ok_exit
    End If

    Dim Item As Object
    Dim Atmt As Attachment
    Dim subjElm() As String                                             ' array of subject line elements
    Dim fileName As String
    Dim year As String
    Dim deptNum As String
    Dim deptName As String
    Dim saveLocation As String

    saveLocation = "C:\Users\drowan\Desktop\TestTestTest\"

    Const sep As String = " "                                          ' separator between elements of resulting filename

    Dim filePrefix As String
    filePrefix = "LAB" & sep & "2016" & sep & "11" & sep & "ENY"       ' begining of each filename

            ' guesses and assumptions made:
            '     LD01_0215 and 0290000xxx signify department numbers
            '     last digit of department number (eg. LD01_0215) is department type
            '     cy, py, ppy .. are year codes

            ' "Monthly Auto Gen Report CY LD01_0210"  ==> "LAB 2016 11 ENY 2016 0290000210 ADMIN"
            ' "Monthly Auto Gen Report PY LD01_0210"  ==> "LAB 2016 11 ENY 2015 0290000210 ADMIN"
            ' "Monthly Auto Gen Report PPY LD01_0210" ==> "LAB 2016 11 ENY 2014 0290000210 ADMIN"
            ' "Monthly Auto Gen Report CY LD01_0215"  ==> "LAB 2016 11 ENY 2016 0290000215 HR"


    Dim i As Integer
    i = 0

    For Each Item In folderItems                                       ' Check each message for attachments
        For Each Atmt In Item.Attachments
            subjElm = Split(LCase(Item.Subject), " ", , vbTextCompare) ' split subject line into an array of words (zero based array)
                                                                       ' lcase function converts subject line to lower case

            '     0      1     2      3     4      5                   ' resulting index values of each element
            ' [Monthly][Auto][Gen][Report][PY][LD01_0210]              ' example subject line split into elements

            Select Case Trim(subjElm(4))
                Case "cy"
                    year = "2016"
                Case "py"
                    year = "2015"
                Case "ppy"
                    year = "2014"
                Case Else                  ' unspecified year
                    year = "noYear"
            End Select

            deptNum = "029000" & Split(subjElm(5), "_")(1)             ' [LD01_0210] ==> [LD01][0210]

            Select Case Right(Trim(subjElm(5)), 1)                     ' last character of LD01_0210
                Case "0"
                    deptName = "ADMIN"
                Case "5"
                    deptName = "HR"
                Case Else                  ' unspecified department
                    deptName = "noDeptName"
            End Select

            fileName = saveLocation & filePrefix & sep & year & sep & deptNum & sep & deptName & ".xls"
            Debug.Print "file path: " & fileName
            Atmt.SaveAsFile fileName

            i = i + 1

        Next Atmt
    Next Item


    If i > 0 Then                                    ' Show summary message

        Dim varResponse As VbMsgBoxResult

        varResponse = MsgBox("I found " & i & " attached file(s)." & vbCrLf _
                           & "I have saved them into the following folder:" & vbCrLf & vbCrLf _
                           & saveLocation & vbCrLf & vbCrLf _
                           & "Would you like to view the files now?" _
                           , vbQuestion + vbYesNo, "Finished!")

        If varResponse = vbYes Then
            Shell "Explorer.exe /e," & saveLocation, vbNormalFocus        ' Open Windows Explorer to display saved files
        Else
            MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        End If

    End If
    GoTo ok_exit

' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." & vbCrLf _
         & "Please note and report the following information." & vbCrLf & vbCrLf _
         & "Macro Name:" & vbTab & "GetAttachments" & vbCrLf & vbCrLf _
         & "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf _
         & "Error Description:" & vbTab & Err.Description _
         , vbCritical, "Error!"

ok_exit:
    Set Atmt = Nothing      ' Clear memory
    Set Item = Nothing
    Set folderItems = Nothing
End Sub

Bulk Attachment Save with File Name Based on Subject

1 Answers1