收件箱规则移动项目时不执行 Item_Add 代码

Question

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

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

我有几个问题。

1. 当规则移动电子邮件时，代码不会运行，只有在我手动移动电子邮件时才会运行。
2. 它会创建新目录并保存第一封电子邮件的附件，但其他电子邮件会导致路径/访问错误引用

MkDir ("C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date, "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")), vbDirectory) = "" Then
        MkDir ("C:\Users\username\Desktop\Outlook Test Folder\" & Format(Date, "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, "YYYY") & "\" & 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, "YYYY") & "\" & 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

Answer 1

1. 仅当我手动移动电子邮件时，规则才移动电子邮件时代码不会运行。

如果将多个项目移动到一个文件夹，ItemAdd 事件可能不会被触发。这是 Outlook 中的一个已知问题。

另一个可能的原因是 Outlook 规则在 Application_Startup 之前运行。

1. 它可以很好地创建新目录并保存第一个电子邮件附件，但是其他电子邮件会导致路径/访问错误

确保使用路径或文件中允许的符号。我建议尝试手动创建相同的路径，以使路径中只使用允许的符号。