将所选项目移动到文件夹

Question

我正在使用以下功能将选定的电子邮件移动到另一个文件夹。

错误提示“找不到对象。”

它第一次工作，但任何后续尝试都失败了：

Set TestFolder = SubFolders.Item(FoldersArray(i))

执行以下行时，当我在监视窗口中展开文件夹时，没有出现子文件夹：

Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))

我正在从一个 sub 调用该函数：

Option Explicit

Private Item As Object, olkItem As Object
Private AutoReply As String
Private myDestFolder As Outlook.Folder, myInbox As Outlook.Folder
Private myNameSpace As Outlook.NameSpace

Sub ReplywithNote2()

Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = GetFolder("\\PO_Queries\Inbox\Completed")

For Each olkItem In Application.ActiveExplorer.Selection
    With olkItem
        If .Class = olMail Then
            '.Move myDestFolder
        End If
    End With
Next

End Sub

功能：

Function GetFolder(ByVal FolderPath As String) As Outlook.Folder

Set GetFolder = Nothing

Dim TestFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

'On Error GoTo GetFolder_Error

If Left(FolderPath, 2) = "\\" Then
    FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If

'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")

Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))

If Not TestFolder Is Nothing Then
    For i = 1 To UBound(FoldersArray, 1)

        Dim SubFolders As Outlook.Folders
        Set SubFolders = TestFolder.Folders
        Set TestFolder = SubFolders.Item(FoldersArray(i))

        If TestFolder Is Nothing Then
            Set GetFolder = Nothing
        End If
    Next
End If

'Return the TestFolder
Set GetFolder = TestFolder
On Error GoTo 0
Exit Function

GetFolder_Error:
Set GetFolder = Nothing
Exit Function

End Function

当我重新启动 Outlook 时，它可以工作。我尝试将几个变量设置为 Nothing，执行“End”以希望重置相关变量。重新启动 Outlook 时会重置什么？

编辑 - 我已将范围缩小到移动线。移动项目后运行 sub 时会出现问题。

Answer 1

For Each 在移动或删除时无法正常工作。

您要么处理第一项，直到没有剩余任何项目，要么向后循环。

For i = Application.ActiveExplorer.Selection.Count to 1 step -1

https://msdn.microsoft.com/en-us/library/office/ff863343%28v=office.15%29.aspx

"要删除一个文件夹的Items集合中的所有项目，必须从文件夹中的最后一个项目开始删除每个项目。例如，在一个文件夹的项目集合中，AllItems，如果有n个项目在文件夹中，开始删除 AllItems.Item(n) 处的项目，每次递减索引，直到删除 AllItems.Item(1)。"

编辑：2015 06 16

除非有使用 GetFolder 的原因，否则试试这个：

Set myDestFolder = myNameSpace.Folders("PO_Queries").Folders("Inbox").Folders("Completed")

Answer 2

非常感谢 niton，我将 sub 修改为以下内容：

Sub ReplywithNote2()

    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = GetFolder("\\PO_Queries\Inbox\Completed")

    For i = Application.ActiveExplorer.Selection.Count To 1 Step -1
        With Application.ActiveExplorer.Selection.Item(i)
            If .Class = olMail Then
                .Move myDestFolder
            End If
        End With
    Next

End Sub

如果我手动将电子邮件移回原始文件夹并重试，问题仍然存在，但我可以忍受！

再次感谢，非常感谢。

Answer 3

Sub myMove()

Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = GetFolder("\\xxx\folder1\folder2\folder3")
Dim i As Long
For Each olkItem In Application.ActiveExplorer.Selection
 i = MsgBox("Do you want to move selected emails to folder folder3?", vbYesNo + vbQuestion + vbSystemModal + vbMsgBoxSetForeground, "Confirm Move")
    If i = vbNo Then
        Cancel = True
        End
      Else
        'Continue moving message
           For i = Application.ActiveExplorer.Selection.Count To 1 Step -1
                With Application.ActiveExplorer.Selection.Item(i)
                    If .Class = olMail Then
                        .Move myDestFolder
                    End If
                End With
           Next
End
    End If

Next

End:
End Sub