我有一些每日报告（excel文件）通过电子邮件发送给我。收件箱规则将电子邮件移动到名为“每日报告”的Outlook文件夹

当电子邮件按规则移入文件夹时，我希望附件自动保存到文件夹并按日期进行组织。类似于：C：\ Desktop \ ReportName \ 2019 \ 11-2019 \ 11-05-2019 Report Name.xlsx

但是，我遇到了几个问题。

1. 仅当我手动移动电子邮件时，规则移动电子邮件时，代码不会运行。
2. 它会很好地创建新目录并保存第一个电子邮件附件，但是其他电子邮件会引用此行提供路径/访问错误“      MkDir（“ C：\ Users \ username \ Desktop \ Outlook Test Folder \”＆格式（日期，“ YYYY”））“

Private WithEvents olItems As Outlook.Items

Private Sub Application_Startup()
    Dim objNS As Outlook.NameSpace

    Set objNS = GetNamespace("MAPI")
    Set olItems = objNS.GetDefaultFolder(olFolderInbox).Parent.Folders("Daily Reports").Items
    Set objNS = Nothing
End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)
    Dim NewMail As Outlook.MailItem
    Dim Atts As Attachments
    Dim strPath As String
    Dim attName As String

    If Item.Class = olMail Then
        Set NewMail = Item
    End If

    If Dir("C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date,"YYYY"),vbDirectory) = "" Then
        MkDir ("C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date,"YYYY"))
    End If

    If Dir("C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date,"YYYY" & "\" & Format(Date,"MM-YYYY")),"YYYY") & "\" & Format(Date,"MM-YYYY"))
    End If

    If InStr(LCase(Item.Subject),"daily applications was executed at") > 0 Then
       strPath = "C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date,"MM-YYYY")
       attName = " Daily Applications.Xlsx"
    ElseIf InStr(LCase(Item.Subject),"dailyopenedcalls was executed at") > 0 Then
            strPath = "C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date,"MM-YYYY")
            attName = " Daily Opened Calls.Xlsx"
    End If

    Set Atts = Item.Attachments

    If Atts.Count > 0 Then
        For Each Att In Atts
            If InStr(LCase(Att.FileName),".xlsx") > 0 Then
                Att.SaveAsFile strPath & "\" & Format(Date,"mm-dd-yyyy") & attName
            End If
        Next
    End If

End Sub
```