Question

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

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

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

仅当我手动移动电子邮件时，规则移动电子邮件时，代码不会运行。
它会很好地创建新目录并保存第一个电子邮件附件，但是其他电子邮件会引用此行提供路径/访问错误“ 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")), 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

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

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

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

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

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

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

1 个答案: