时间戳

首页 > 解决方案 > 如果主题行匹配，则将电子邮件保存到文件夹

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

问题描述

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

这段代码最终将被复制用于 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

标签： vbaoutlook

解决方案

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

NewMailEx 事件在新邮件到达收件箱时触发，在客户端规则处理发生之前。您可以使用 EntryIDCollection 数组中返回的条目 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

推荐阅读