VBA - Save a copy of an email to a monthly reports folder

SendToMonthlyReport.vba

' Copy the item(s) to the monthly report folder
Sub SaveToMonthlyReport()
    ' Gotta grab the MAPI namespace to get the folders
    Set ns = Application.GetNamespace("MAPI")
    Dim fldRoot As MAPIFolder
    Set fldRoot = ns.GetDefaultFolder(olFolderInbox)
    
    ' Start with the root folder (create if necessary)
    On Error GoTo ErrorHandlerFolderReports
    Set fldReports = fldRoot.Folders("Monthly Reports")
    
    ' Get the current year's folder (create if necessary)
    On Error GoTo ErrorHandlerFolderYear
    Set fldYear = fldReports.Folders(CStr(Year(Date)))
    
    ' Get the current month's folder (create if necessary)
    On Error GoTo ErrorHandlerFolderMonth
    Set fldMonth = fldYear.Folders(MonthName(Month(Date)))
                  
    ' Copy the item(s) to the folder
    On Error GoTo ErrorHandler
    Set itemsSelected = Application.ActiveExplorer.Selection
    For i = 1 To itemsSelected.Count
        Set itemCopy = itemsSelected(i).Copy
                
        ' Build the new categories list (and trim off extra comma)
        cats = "Monthly Report"
        If (Not itemCopy.Categories = "") Then cats = cats & "," & itemCopy.Categories
        
        With itemCopy
            .UnRead = False
            .MarkAsTask olMarkComplete
            .Categories = cats
            .Save
        End With
        
        ' Move the item
        itemCopy.Move fldMonth
        
        ' Release the object(s)
        Set itemCopy = Nothing
    Next i
    
    ' Release the object(s)
    Set itemsSelected = Nothing
    Set fldMonth = Nothing
    Set fldYear = Nothing
    Set fldReports = Nothing
    Set fldRoot = Nothing
    Set ns = Nothing
    Exit Sub
    
ErrorHandlerFolderReports:
    Set fldReports = fldRoot.Folders.Add("0. Monthly Reports")
    Resume Next
ErrorHandlerFolderYear:
    Set fldYear = fldReports.Folders.Add(CStr(Year(Date)))
    Resume Next
ErrorHandlerFolderMonth:
    Set fldMonth = fldYear.Folders.Add(MonthName(Month(Date)))
    Resume Next
ErrorHandler:
    If Err.Number <> 0 Then
        Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
    Resume Next
End Sub