Question

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

123456
123457个
123458个
等等...

我认为我正在寻找的是一个矢量，但是没有多少经验，所以请你帮我找一个方法来立即插入所有标准来移动文件夹并识别无法找到/移动的ID？

以下是我到目前为止（在文本框中搜索输入的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

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

1 个答案: