发送到通讯组的电子邮件不是 MailItems？答案

【问题标题】：Emails to a distribution group aren't MailItems?发送到通讯组的电子邮件不是 MailItems？
【发布时间】：2016-07-04 13:41:21
【问题描述】：

我正在尝试为 Outlook 2007 编写一个 VBA 脚本，如果用户的邮件超过 89 天，它将移动到“过期”文件夹。我有执行此操作的代码，但它似乎不适用于发往包含最终用户的通讯组的旧电子邮件。它适用于刚刚发送给最终用户的电子邮件。

我结合了我在网上找到的代码 a) 在电子邮件有一定天数时移动它们 (http://www.slipstick.com/developer/macro-move-aged-mail/)，以及 b) 通过文件夹递归以将代码也应用于子文件夹 (Can I iterate through all Outlook emails in a folder including sub-folders?)。此代码通过收件箱文件夹和子文件夹递归移动所有过期邮件。

它或多或少有效，但由于某种原因，发送到包含最终用户的分发列表的电子邮件没有被接收。我唯一值得注意的检查是

    If TypeName(oItem) = "MailItem"

分发列表电子邮件是否不被视为 MailItems？如果没有，我如何确保也抓住这些？

完整代码如下：

    Public Sub MoveAgedMail(Item As Outlook.MailItem)

        Dim objOutlook As Outlook.Application
        Dim objNamespace As Outlook.NameSpace
        Dim objSourceFolder As Outlook.MAPIFolder
        Dim objVariant As Variant
        Dim lngMovedItems As Long
        Dim intCount As Integer
        Dim intDateDiff As Integer
        Dim strDestFolder As String
        Dim Folder As Outlook.MAPIFolder

        Dim oFolder As Outlook.MAPIFolder
        Dim oMail As Outlook.MailItem

        Set objOutlook = Application
        Set objNamespace = objOutlook.GetNamespace("MAPI")
        Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

        ' Call processFolder
        processFolder objSourceFolder


    End Sub

    Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)

            Dim oFolder As Outlook.MAPIFolder
            Dim oMail As Outlook.MailItem
            Dim oItem As Object
            Dim intCount As Integer
            Dim intDateDiff As Long
            Dim objDestFolder As Outlook.MAPIFolder

        ' "Expired" folder at same level as Inbox for sending aged mail        
        Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")

            For Each oItem In oParent.Items
                If TypeName(oItem) = "MailItem" Then
                    Set oMail = oItem

                    ' Check if email is older than 89 days
                    intDateDiff = DateDiff("d", oMail.SentOn, Now)


                    If intDateDiff > 89 Then

                   ' Move to "Expired" folder
                    oMail.Move objDestFolder

                    End If
                End If

            Next oItem

        ' Recurse through subfolders
            If (oParent.Folders.Count > 0) Then
                For Each oFolder In oParent.Folders
                    processFolder oFolder
                Next
            End If
            Set objDestFolder = Nothing
    End Sub

【问题讨论】：

问题邮件是否通过TypeName() 测试？
我认为它的击球手使用 For Loop With Step Backwards 然后在移动 mailitems 时使用 For Each

标签： vba email outlook outlook-2007

【解决方案1】：

首先，如果您正在修改集合，请不要使用for each - 这会导致您的代码跳过一半的项目。

其次，不要只循环浏览文件夹中的所有项，这是非常低效的。使用Items.Restrict 或Items.Find/FindNext。

尝试如下（VB 脚本）：

d = Now - 89
strFilter = "[SentOn]  < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
set oItems = oParent.Items.Restrict(strFilter)
for i = oItems.Count to 1 step -1
  set oItem = oItems.Item(i)
  Debug.Print oItem.Subject & " " & oItem.SentOn
next

【讨论】：

这很有帮助。我将脚本更改为以下内容。
我会将其作为回复发布。

【解决方案2】：

尽量不要处理Expired文件夹

    ' Recurse through subfolders
        If (oParent.Folders.Count > 0) Then
            For Each oFolder In oParent.Folders
            Debug.Print oFolder
                ' No need to process Expired folder
                If oFolder.Name <> "Expired" Then
                    processFolder oFolder
                End If
            Next
        End If

在移动邮件时也可以尝试使用向下循环，参见Dmitry Streblechenko 示例

编辑

Items.Restrict Method (Outlook)

完整代码 - 在 Outlook 2010 上测试

Sub MoveAgedMail(Item As Outlook.MailItem)
    Dim olNameSpace As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)

'   // Call ProcessFolder
    ProcessFolder olInbox

End Sub

Function ProcessFolder(ByVal Parent As Outlook.MAPIFolder)
    Dim Folder As Outlook.MAPIFolder
    Dim DestFolder As Outlook.MAPIFolder
    Dim iCount As Integer
    Dim iDateDiff As Long
    Dim vMail As Variant
    Dim olItems As Object
    Dim sFilter As String

    iDateDiff = Now - 89
    sFilter = "[SentOn]  < '" & Month(iDateDiff) & "/" & Day(iDateDiff) & "/" & Year(iDateDiff) & "'"

'   // Loop through the items in the folder backwards
    Set olItems = Parent.Items.Restrict(sFilter)

    For iCount = olItems.Count To 1 Step -1
        Set vMail = olItems.Item(iCount)

        Debug.Print vMail.Subject ' helps me to see where code is currently at 

'       // Filter objects for emails
        If vMail.Class = olMail Then
            Debug.Print vMail.SentOn

'           //  Retrieve a folder for the destination folder
            Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Expired")

'           // Move the emails to the destination folder
            vMail.Move DestFolder

'           // Count number items moved
            iCount = iCount + 1

        End If
    Next

'   // Recurse through subfolders
    If (Parent.Folders.Count > 0) Then
        For Each Folder In Parent.Folders
            If Folder.Name <> "Expired" Then ' skip Expired folder
                Debug.Print Folder.Name
                ProcessFolder Folder
            End If
        Next
    End If

    Debug.Print "Moved " & iCount & " Items"

End Function

【讨论】：

遍历所有项目仍然是一个非常糟糕的主意。尝试在包含 10,000 多个项目的文件夹上运行脚本。您也不应该在循环中使用多个点表示法 (Parent.Items.Item(iCount)) - 在进入循环之前缓存 Items 集合。
@DmitryStreblechenko 现在怎么样？在包含 23,146 items 的文件夹上测试
为什么在循环内将 DestFolder 设置为 Nothing，而您仍需要处理更多项目？ DoEvents 也不是一个好主意。

【解决方案3】：

这是我现在的代码。最初，我将旧邮件移动到“过期”文件夹并自动存档删除了这些邮件，但我在某些机器上遇到了自动存档问题。我重写了删除旧电子邮件的脚本。它使用了 Dmitry Streblechenko 的建议，并且似乎有效。

Public Sub DeleteAgedMail()
   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objSourceFolder As Outlook.MAPIFolder
   Dim objSourceFolderSent As Outlook.MAPIFolder

   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
   Set objSourceFolderSent = objNamespace.GetDefaultFolder(olFolderSentMail)

   processFolder objSourceFolder
   processFolder objSourceFolderSent
   emptyDeleted  
End Sub

Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
   Dim oItems As Outlook.Items
   Dim oItem As Object
   Dim intDateDiff As Long
   Dim d As Long
   Dim strFilter As String    

   d = Now - 89
   strFilter = "[SentOn]  < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
   Set oItems = oParent.Items.Restrict(strFilter)
   For i = oItems.Count To 1 Step -1
       Set oItem = oItems.Item(i)
       If TypeName(oItem) = "MailItem" Then
         oItem.UserProperties.Add "Deleted", olText
         oItem.Save
         oItem.Delete
       End If
   Next
   If (oParent.Folders.Count > 0) Then
       For Each oFolder In oParent.Folders
           processFolder oFolder
       Next
   End If   
End Sub

Public Sub emptyDeleted()
   Dim objOutlook As Outlook.Application
   Dim myNameSpace As Outlook.NameSpace
   Dim objDeletedFolder As Outlook.MAPIFolder
   Dim objProperty As Outlook.UserProperty

   Set objOutlook = Application
   Set myNameSpace = objOutlook.GetNamespace("MAPI")
   Set objDeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)

   For Each objItem In objDeletedFolder.Items
       Set objProperty = objItem.UserProperties.Find("Deleted")
       If TypeName(objProperty) <> "Nothing" Then
           objItem.Delete
       End If
   Next
End Sub

如果你只想移动电子邮件而不是删除它们，就像在我的原始代码中一样，你可以去掉 emptyDeleted() 函数，更改

oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete

 oItem.Move objDestFolder

并将这两行添加回 processFolder() 函数：

Dim objDestFolder As Outlook.MAPIFolder      
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")

【讨论】：