如何通过VBA实现Outlook共享邮箱不同文件夹间的邮件移动

• 参考资料编写的Outlook VBA代码在个人邮箱环境可正常运行，实现功能为：将个人收件箱内选中邮件移动到收件箱下名为Test的子文件夹
• 代码迁移到共享邮箱场景后失效，新需求为：将共享邮箱收件箱内的邮件，移动到与该收件箱同级、名为Complete的独立文件夹
• 原有测试代码如下：

Sub MailmoveAP()
          
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim InboxItem As Object

    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.GetSharedDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("Test")

    For Each msg In ActiveExplorer.Selection
       msg.Move olFolder
    Next
            
End Sub

• 原有代码失效原因：
  • 调用GetSharedDefaultFolder方法时缺失必填的共享邮箱收件人参数，无法正确定位共享邮箱存储
  • 文件夹路径写死为收件箱下的子文件夹，和Complete与收件箱同级的实际路径不匹配
  • 未做异常校验，遇到文件夹不存在、选中项非邮件类内容时会直接抛出运行时错误

替换为以下代码即可实现需求：

Sub MailmoveAP()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim sharedInbox As Outlook.MAPIFolder
    Dim sharedRoot As Outlook.MAPIFolder
    Dim targetFolder As Outlook.MAPIFolder
    Dim selectedItem As Object
    Dim sharedRecipient As Outlook.Recipient
    
    ' 初始化Outlook基础对象
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    
    ' 替换为实际共享邮箱的完整邮件地址
    Const SHARED_EMAIL As String = "your_shared_mailbox@company.com"
    
    ' 校验共享邮箱访问权限
    Set sharedRecipient = objNS.CreateRecipient(SHARED_EMAIL)
    sharedRecipient.Resolve
    If Not sharedRecipient.Resolved Then
        MsgBox "无法访问指定共享邮箱，请确认地址正确且你拥有对应权限", vbCritical
        Exit Sub
    End If
    
    ' 定位目标文件夹：共享邮箱根目录下的Complete文件夹（与收件箱同级）
    Set sharedInbox = objNS.GetSharedDefaultFolder(sharedRecipient, olFolderInbox)
    Set sharedRoot = sharedInbox.Parent
    On Error Resume Next
    Set targetFolder = sharedRoot.Folders("Complete")
    On Error GoTo 0
    If targetFolder Is Nothing Then
        MsgBox "共享邮箱根目录下未找到名为Complete的文件夹，请确认名称匹配", vbCritical
        Exit Sub
    End If
    
    ' 遍历选中内容，仅移动邮件类型项
    For Each selectedItem In ActiveExplorer.Selection
        If TypeName(selectedItem) = "MailItem" Then
            selectedItem.Move targetFolder
        End If
    Next
    
    ' 释放对象内存
    Set selectedItem = Nothing
    Set targetFolder = Nothing
    Set sharedRoot = Nothing
    Set sharedInbox = Nothing
    Set sharedRecipient = Nothing
    Set objNS = Nothing
    Set olApp = Nothing
End Sub

• 运行代码前，将常量SHARED_EMAIL的取值替换为你实际使用的共享邮箱完整地址
• 确认共享邮箱根目录下的目标文件夹名称为Complete，名称前后不要有多余空格，大小写需要完全匹配
• 代码会自动跳过选中内容里的会议邀请、任务、日历项等非邮件内容，避免触发运行错误

内容的提问来源于stack exchange，提问作者Lydo88