使用 vba 搜索和移动多个 Outlook 文件夹

Question

我需要整理我的箱子，并且需要将所有已关闭的箱子移至特定文件夹。
我设法找到了一种方法，但这个解决方案一次只能移动 1 个文件夹，问题是有超过 200 个案例需要移动。
所有文件夹都在一个共享的电子邮件帐户中，我可以通过文件夹名称末尾的最后 6 个字符来识别需要移动的文件夹，这实际上是一个唯一的 ID。具体来说，一个文件夹以这种方式命名：“XX.ddmmyy.string.string.XX.ID”
我用于识别和移动此文件夹的唯一数据是一个带有 ID 的列表，该列表包含在这样的 excel 文件中：

123456
123457
123458
等等……

我认为我正在搜索的是一个向量，但没有太多经验，所以请你帮我想出一种方法来移动以一次插入所有条件以移动文件夹并识别 ID找不到/移动哪个？

这是我目前所拥有的（在文本框中搜索输入的 ID，遍历文件夹，将其移动到特定的一个并显示一个消息框）。 我运行 FindFolder 宏。

Private myFolder As Outlook.MAPIFolder
Private MyFolderWild As Boolean
Private MyFind As String

Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders
Dim myNewFolder As Outlook.folder
Dim olApp As Outlook.Application
Dim NS As NameSpace
Dim olDestFolder As Object
Dim folder_name As String

Set myFolder = Nothing
MyFind = ""
MyFolderWild = False

Name = "*" & InputBox("Enter the Folder Name that you would like to find:")
If Len(Trim$(Name)) = 0 Then Exit Sub
MyFind = Name

MyFind = LCase$(MyFind)
MyFind = Replace(MyFind, "%", "*")
MyFolderWild = (InStr(MyFind, "*"))

Set Folders = Application.Session.Folders
LoopFolders Folders

If Not myFolder Is Nothing Then
If MsgBox("Do you want to move this folder ?" & vbCrLf &   myFolder.folderPath, vbQuestion Or vbYesNo, "Found your Folder:") = vbYes Then
    Set Application.ActiveExplorer.CurrentFolder = myFolder
    Set olApp = Application
    Set NS = olApp.GetNamespace("MAPI")
    Set olDestFolder = NS.Folders("xx@xx.com").Folders("Inbox").Folders("cleanup")
    myFolder.MoveTo olDestFolder
Call Repeat
End If
Else
MsgBox "The folder you were looking for can not be found.", vbCritical, "Folder NOT found:"
End If
End Sub


Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean

For Each F In Folders
If MyFolderWild Then
  Found = (LCase$(F.Name) Like MyFind)
Else
  Found = (LCase$(F.Name) = MyFind)
End If

If Found Then
  Set myFolder = F
  Exit For
Else
  LoopFolders F.Folders
  If Not myFolder Is Nothing Then Exit For
End If
Next
End Sub


Sub Repeat()
If MsgBox("The folder has been succesfully moved." & vbCrLf & "Do you want to move another folder?", vbQuestion Or vbYesNo) = vbYes Then
Call FindFolder
Else
End
Exit Sub
End If
End Sub

非常感谢！

Answer 1

我建议在 Excel 中键入（要移动的文件夹的）列表。然后将以下代码添加到Excel中

Public Sub MoveFolders(rInputRange As Range)

    Dim rCell As Range

    For Each rCell In Selection
        rCell.Offset(0, 1) = MoveFolder("*" & rCell)
    Next rCell

End Sub

Public Function MoveFolder(sSearchName As String) As Boolean

    Const DESTINATION_FOLDER As String = "linkedin"

    Dim oFoundFolder        As Outlook.Folder
    Dim oDestinationFolder  As Outlook.Folder

    Set oFoundFolder = FindFolderRecursive(sSearchName)

    If oFoundFolder Is Nothing Then
        MoveFolder = False
    Else
        Set oDestinationFolder = FindFolderRecursive(DESTINATION_FOLDER)
        oFoundFolder.MoveTo oDestinationFolder
        MoveFolder = True
    End If

End Function

Public Function FindFolderRecursive(sSearchName As String, Optional oFolder As Folder = Nothing) As Folder

    Dim oSubFolder          As Outlook.Folder
    Dim oFolders            As Outlook.Folders

    If oFolder Is Nothing Then
        Set oFolders = Outlook.Application.Session.Folders
    Else
        Set oFolders = oFolder.Folders
    End If

    For Each oSubFolder In oFolders
        If LCase(oSubFolder.Name) Like LCase(sSearchName) Then
            Set FindFolderRecursive = oSubFolder
            Exit Function
        Else
            Set FindFolderRecursive = FindFolderRecursive(sSearchName, oSubFolder)
            If Not FindFolderRecursive Is Nothing Then Exit Function
        End If
    Next oSubFolder

End Function

请务必参考 Outlook 库。

如果选择列表，则可以在即时窗口中使用以下代码为所有文件夹执行代码

MoveFolders Selection