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

Question

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

123456
123457
123458
等等...

我想我正在搜索的是一个矢量，但没有太多经验，所以你能帮我想办法移动一次插入所有条件来移动文件夹并识别不能是 found/moved?

的 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 库。

如果您select列表，那么您可以立即使用以下代码对所有文件夹执行代码window

MoveFolders Selection

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

Search and move multiple Outlook folders using vba

directory

outlook

vba

move

outlook-2007