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

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