Outlook 清理移动共享邮箱上的邮件文件夹和子文件夹以删除 SH 文件夹

Question

我得到了以下代码，是我自己动手做的:) 我设法让删除 pcik 起来，但理想情况下我想 1-默认获取 sh delete 文件夹 pick 进行删除 2-避免循环删除文件夹 3- 如果可能，加快代码速度，因为邮箱的大小 > 100 万封邮件 4- 我设法让它没有错误，但可以跟踪进度.....

有人能帮忙吗？提前致谢

Dim objNameSpace As Outlook.NameSpace
Dim objMainFolder As Outlook.Folder
Dim olNs As NameSpace
Dim lngItem As Long
Dim Mails_itm As MailItem
Dim myNameSpace As Outlook.NameSpace
Dim myInboxDest As Outlook.Folder
Dim myInboxSc As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object

Set objNameSpace = Application.GetNamespace("MAPI")
Set objMainFolder = objNameSpace.PickFolder

 Call ProcessCurrentFolder(objMainFolder)

End Sub

ProcessCurrentFolder(ByVal objParentFolder As Outlook.MAPIFolder)

    Dim objCurFolder As Outlook.MAPIFolder
    Dim objMail As Outlook.MailItem
    Dim DeletedFolder As Outlook.Folder
    Dim olNs As Outlook.NameSpace
    Dim lngItem As Long
    On Error Resume Next
  
    Set olNs = Application.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
   For Each objMail In objParentFolder.Items
     i = 0
     For lngItem = objParentFolder.Items.Count To 1 Step -1
        Set objMail = objParentFolder.Items(lngItem)
        If TypeName(objMail) = "MailItem" Then
            If ((objMail.ReceivedTime) < DateAdd("yyyy", -7, Date)) Then         
                    objMail.Move DeletedFolder
               i = i + 1
            End If
        End If
        DoEvents
        Next lngItem
    Next
    If (objParentFolder.Folders.Count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder)
        Next
    End If
End Sub

Answer 1

提问时，最好时不时地检查一下，如果有澄清问题，就回答一下...

假设您的第一个需求问题是替换文件夹选择器选项并直接设置objMainFolder，您的第一个代码应修改为：

Sub ProcessOldMails()
 Dim objNameSpace As outlook.NameSpace
 Dim objMainFolder As outlook.Folder

 Set Out = GetObject(, "Outlook.Application")
 Set objNameSpace = Out.GetNamespace("MAPI")

 Set objNameSpace = Application.GetNamespace("MAPI")
 'Set objMainFolder = objNameSpace.PickFolder 'uncomment if my supposition is wrong
 'set the folder to be processed directly, if it is an InBox subfolder:
 'Please use its real name instead of "MyFolderToProcess":
 Set objMainFolder = objNameSpace.GetDefaultFolder(olFolderInbox).Folders("MyFolderToProcess")
    ProcessCurrentFolder objMainFolder, Application
End Sub

为了加快处理速度，您可以过滤文件夹内容并仅在剩余邮件之间迭代：

Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
    Dim objCurFolder As outlook.MAPIFolder
    Dim objMail As outlook.MailItem
    Dim DeletedFolder As outlook.Folder
    Dim olNs As outlook.NameSpace
    Dim lngItem As Long, strFilter As String, oItems As items
  
    Set olNs = app.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
    
    strFilter = "[ReceivedTime]<'" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
    Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
     Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
   For lngItem = oItems.count To 1 Step -1
       oItems(lngItem).Move DeletedFolder
   Next lngItem
   If (objParentFolder.Folders.count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder, app)
        Next
   End If
End Sub

我使用 app 第二个参数只是因为我尝试将其作为来自 Excel 的 Outlook 自动化，并且只插入两行更容易...

请测试建议的解决方案并发送一些反馈。如果我的理解不正确，请不要犹豫，要求澄清，首先从评论中回答我的问题。

现在，我需要出去...

Answer 2

使用 Find/FindNext 或 Restrict 方法获取符合您的条件的项目，而不是遍历文件夹中的所有项目。在以下文章中阅读有关这些方法的更多信息：

How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder

当您遍历找到的项目并将它们移动到另一个文件夹时，您必须使用反向循环来防止运行时出错，因为通过调用 Move 方法减少项目数量会导致项目数量减少。

Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
    Dim objCurFolder As outlook.MAPIFolder
    Dim objMail As outlook.MailItem
    Dim DeletedFolder As outlook.Folder
    Dim olNs As outlook.NameSpace
    Dim lngItem As Long, strFilter As String, oItems As items
  
    Set olNs = app.GetNamespace("MAPI")
    Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
    
    strFilter = "[ReceivedTime] < '" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
    Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
     Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
  For i = oItems.Count to 1 Step -1
        Set objMail = oItems(i)
        objMail.Move DeletedFolder
  Next
   
   ' it makes sense to move this part to the beginning of the method to process subfolders first  
   If (objParentFolder.Folders.count > 0) Then
        For Each objCurFolder In objParentFolder.Folders
            Call ProcessCurrentFolder(objCurFolder, app)
        Next
   End If
End Sub

有关详细信息，请参阅 For Each loop: Some items get skipped when looping through Outlook mailbox to delete items。

Outlook 清理移动共享邮箱上的邮件文件夹和子文件夹以删除 SH 文件夹

Outlook Clean up move mail folders and subfolders on shared mail box to delete SH folder

outlook

vba