Question

如果主题行包含正确的术语，我会尝试将电子邮件到达时保存到文件夹中。

此代码最终将被复制为75-80个项目，且主题行各不相同。

Option Explicit

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    If objItem.Class = olMail Then
        Set msgNew = objItem
        If (msgNew.Subject Like "Client Media Report*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "M:\AutoArchive\Client Media Report\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "M:\AutoArchive\Client Media Report\" & DateYr & "\" & DateMonth & ".msg"
        End If
    End If
End Sub

我希望这会将新电子邮件保存到正确的文件夹中。例如，该示例将保存到M:\AutoArchive\Client Media Report\2019\08. August

它不保存，也不会吐出错误。

主题行示例：Client Media Report 05 August 2019

示例文件位置：M:\AutoArchive\Client Media Report\2019\08. August

编辑：已更新为最新代码，事件触发了错误

无法打开项目

上

Set mai = Application.Session.GetItemFromID(strEntryId)

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    MsgBox ("Test1")

    Dim mai As Object
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    Set mai = Application.Session.GetItemFromID(strEntryId)
    MsgBox mai.Subject

    If mai.Class = olMail Then
    Set msgNew = objItem
        If (msgNew.Subject Like "DPS Front Pages*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "D:\AutoArchive\Full Front Pages\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "D:\AutoArchive\Full Front Pages\" & DateYr & "\" & DateMonth & msgNew.Subject & ".msg"
        End If
    End If

End Sub

Answer 1

您需要处理Application类的NewMailEx事件，该事件在收件箱中收到新项目时触发。

当新邮件到达收件箱时以及在客户端规则处理发生之前，NewMailEx事件将触发。您可以使用EntryIDCollection数组中返回的Entry ID来调用NameSpace.GetItemFromID方法并处理该项目。请谨慎使用此方法，以最小化对Outlook性能的影响。但是，根据客户端计算机上的设置，新邮件到达收件箱后，垃圾邮件过滤和客户端规则等过程会将新邮件从收件箱移至另一个文件夹，这些过程可能会异步发生。

Private Sub NewMailEx(ByVal EntryIDCollection As String)
    Dim mai As Object
    Dim msgNew As MailItem
    Dim DateYr As Object
    Dim DateMonth As Object

    Set mai = Application.Session.GetItemFromID(strEntryId)
    MsgBox mai.Subject

    If mai.Class = olMail Then
    Set msgNew = objItem
    If (msgNew.Subject Like "Client Media Report*") Then
            DateYr = Format(Now(), "yyyy", vbUseSystemDayOfWeek, vbUseSystem)
            DateMonth = Format(Now(), "mm. mmmm", vbUseSystemDayOfWeek, vbUseSystem)

            On Error Resume Next
            MkDir "M:\AutoArchive\Client Media Report\" & DateYr
            On Error GoTo 0
            msgNew.SaveAs "M:\AutoArchive\Client Media Report\" & DateYr & "\" & DateMonth & msgNew.Subject & ".msg"
        End If
    End If

End Sub

如果主题行匹配，将电子邮件保存到文件夹

1 个答案: