Question

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

我将在网上找到的代码组合起来用于a）移动电子邮件，当它们已经过了一定天数（http://www.slipstick.com/developer/macro-move-aged-mail/），以及b）通过文件夹递归以将代码应用到子文件夹（{{3 }}）。此代码通过收件箱文件夹和子文件夹进行递归，以移动所有旧邮件。

它或多或少有效，但由于某种原因，电子邮件到包含最终用户的分发列表中没有被提取。我唯一值得一提的是

    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

Answer 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

Answer 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

Answer 3

这是我的代码。最初，我把旧邮件移到了＃34; Expired＆＃34;文件夹和autoarchive删除邮件，但我在某些机器上遇到autoarchive问题。我重写了脚本以删除旧电子邮件。它使用了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")

发送给发布组的电子邮件不是MailItems吗？

3 个答案: