使用动态路径将电子邮件移动到公用文件夹

Question

在我们的企业环境中，我们有一个带有许多子文件夹的邮箱（不是默认收件箱）。我们还有一个公用文件夹，它与邮箱文件夹结构完全相同。

我正在尝试检测选定电子邮件的路径，并将该电子邮件移动到公用文件夹中的镜像文件夹。

我会说95％的这段代码是正确的，但我留下了一个Outlook错误信息“无法移动项目”。

的代码应该执行以下步骤：
1.检测所选择的电子邮件（多个）
2.转换MAPIFolder成路径字符串
3的当前文件夹缩短串以除去根信箱目录结构
4.添加剩余的串到公用文件夹
5.转换所得路径的根目录结构回一个MAPIFolder
6.移动所选择的电子邮件（一个或多个），以在公共镜像文件夹文件夹

Sub PublicFolderAutoArchive() 

    Dim olApp As Object 
    Dim currentNameSpace As NameSpace 
    Dim wipFolder As MAPIFolder 
    Dim objFolder As MAPIFolder 
    Dim pubFolder As String 
    Dim wipFolderString As String 
    Dim Messages As Selection 
    Dim itm As Object 
    Dim Msg As MailItem 
    Dim Proceed As VbMsgBoxResult 

    Set olApp = Application 
    Set currentNameSpace = olApp.GetNamespace("MAPI") 
    Set wipFolder = Application.ActiveExplorer.CurrentFolder 
    Set Messages = ActiveExplorer.Selection 

    ' Destination root directory' 
    ' Tried with both "\\Public Folders" and "Public Folders" .. neither worked 
    pubFolder = "\\Public Folders\All Public Folders\InboxMirror" 

    ' wipFolder.FolderPath Could be any folder in our mailbox such as: 
    ' "\\Mailbox - Corporate Account\Inbox\SubFolder1\SubFolder2" 
    ' however, the \\Mailbox - Corporate Account\Inbox\" part is 
    ' static and never changes so the variable below removes the static 
    ' section, then the remainder of the path is added onto the root 
    ' of the public folder path which is an exact mirror of the inbox. 
    ' This is to allow a dynamic Archive system where the destination 
    'path matches the source path except for the root directory. 
    wipFolderString = Right(wipFolder.FolderPath, Len(wipFolder.FolderPath) - 35) 

    ' tried with and without the & "\" ... neither worked 
    Set objFolder = GetFolder(pubFolder & wipFolderString & "\") 

    If Messages.Count = 0 Then 
     Exit Sub 
    End If 

    For Each itm In Messages 
     If itm.Class = olMail Then 
      Proceed = MsgBox("Are you sure you want archive the message to the Public Folder?", _ 
      vbYesNo + vbQuestion, "Confirm Archive") 
      If Proceed = vbYes Then 
       Set Msg = itm 
       Msg.Move objFolder 
      End If 
     End If 
    Next 
End Sub 

Public Function GetFolder(strFolderPath As String) As MAPIFolder 
    ' strFolderPath needs to be something like 
    ' "Public Folders\All Public Folders\Company\Sales" or 
    ' "Personal Folders\Inbox\My Folder" 

    Dim objApp As Outlook.Application 
    Dim objNS As Outlook.NameSpace 
    Dim colFolders As Outlook.Folders 
    Dim objFolder As Outlook.MAPIFolder 
    Dim arrFolders() As String 
    Dim I As Long 
    On Error Resume Next 

    strFolderPath = Replace(strFolderPath, "/", "\") 
    arrFolders() = Split(strFolderPath, "\") 
    Set objApp = Application 
    Set objNS = objApp.GetNamespace("MAPI") 
    Set objFolder = objNS.Folders.Item(arrFolders(0)) 
    If Not objFolder Is Nothing Then 
    For I = 1 To UBound(arrFolders) 
     Set colFolders = objFolder.Folders 
     Set objFolder = Nothing 
     Set objFolder = colFolders.Item(arrFolders(I)) 
     If objFolder Is Nothing Then 
     Exit For 
     End If 
    Next 
    End If 

Set GetFolder = objFolder 
Set colFolders = Nothing 
Set objNS = Nothing 
Set objApp = Nothing 
End Function 

注意：上面的邮箱只是一个示例，并不是实际的邮箱名称。我使用MsgBox来确认路径字符串与所有适当的反斜杠正确连接，并且Right（）函数正在从源路径中获取所需内容。

Answer 1

我不确定，但应该是这样的？

set objApp = New Outlook.Application 

代替

set objApp = Application 

Answer 2

从代码一眼，看来你GetFolder()实现不喜欢你在路径的开始给予双反斜线。在函数的开始部分甚至有评论指出这一点。尝试从pubFolder的正面删除这两个字符。

或者，您可以更改GetFolder以允许它们。像这样的几行应该做的伎俩。

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