如何通过Excel VBA修改Outlook已发送邮件的保存文件夹

1. On Error Resume Next 屏蔽错误：这条语句会隐藏所有运行时错误，导致你无法知晓objFolder赋值失败的具体原因（比如找不到共享邮箱、文件夹名称拼写错误等）。
2. 默认邮箱定位错误：原代码通过objNS.GetDefaultFolder(5).Parent获取的是当前登录用户个人邮箱的根目录，而非共享邮箱的根目录，自然找不到共享邮箱下的Training文件夹。

方案一：通过共享邮箱地址定位（推荐） #

此方法直接通过共享邮箱的邮箱地址定位目标文件夹，准确性更高：

Sub SendActiveWorkbookSavingToOtherFolder()
    Dim appOutlook As Object
    Dim mItem As Object
    Dim objNS As Object
    Dim objFolder As Object
    Dim sharedMailbox As Object
    
    ' 绑定已运行的Outlook实例
    Set appOutlook = GetObject(, "Outlook.Application")
    Set objNS = appOutlook.GetNamespace("MAPI")
    
    ' 替换为你的共享邮箱地址
    Set sharedMailbox = objNS.CreateRecipient("shared_mailbox@domain.com")
    sharedMailbox.Resolve
    
    ' 检查共享邮箱是否能被解析
    If Not sharedMailbox.Resolved Then
        MsgBox "无法定位共享邮箱，请检查邮箱地址"
        Exit Sub
    End If
    
    ' 获取共享邮箱的根目录下的Training文件夹（6对应收件箱，取Parent即根目录）
    Set objFolder = objNS.GetSharedDefaultFolder(sharedMailbox, 6).Parent.Folders("Training")
    
    ' 检查文件夹是否存在
    If objFolder Is Nothing Then
        MsgBox "共享邮箱下未找到Training文件夹"
        Exit Sub
    End If
    
    ' 创建并发送邮件
    Set mItem = appOutlook.CreateItem(0)
    With mItem
        .To = "email@domain.com"
        .Subject = ActiveWorkbook.Name
        .Attachments.Add ActiveWorkbook.FullName
        .SaveSentMessageFolder = objFolder
        .Send
    End With
    
    ' 清理对象
    Set mItem = Nothing
    Set objFolder = Nothing
    Set sharedMailbox = Nothing
    Set objNS = Nothing
    Set appOutlook = Nothing
End Sub

方案二：通过共享邮箱显示名称定位 #

如果你不知道共享邮箱地址，只知道其在Outlook中的显示名称，可使用此方法：

Sub SendActiveWorkbookSavingToOtherFolder()
    Dim appOutlook As Object
    Dim mItem As Object
    Dim objNS As Object
    Dim objFolder As Object
    Dim store As Object
    
    ' 绑定已运行的Outlook实例
    Set appOutlook = GetObject(, "Outlook.Application")
    Set objNS = appOutlook.GetNamespace("MAPI")
    
    ' 遍历所有邮箱存储，找到目标共享邮箱（替换为实际显示名称）
    For Each store In objNS.Stores
        If store.DisplayName = "共享邮箱显示名称" Then
            ' 获取共享邮箱根目录下的Training文件夹
            Set objFolder = store.GetDefaultFolder(6).Parent.Folders("Training")
            Exit For
        End If
    Next store
    
    ' 检查文件夹是否存在
    If objFolder Is Nothing Then
        MsgBox "未找到目标共享邮箱或Training文件夹"
        Exit Sub
    End If
    
    ' 创建并发送邮件
    Set mItem = appOutlook.CreateItem(0)
    With mItem
        .To = "email@domain.com"
        .Subject = ActiveWorkbook.Name
        .Attachments.Add ActiveWorkbook.FullName
        .SaveSentMessageFolder = objFolder
        .Send
    End With
    
    ' 清理对象
    Set mItem = Nothing
    Set objFolder = Nothing
    Set store = Nothing
    Set objNS = Nothing
    Set appOutlook = Nothing
End Sub

• 确保所有使用该工作簿的用户，Outlook中已正常添加并能访问目标共享邮箱
• Training文件夹必须位于共享邮箱的根层级（与收件箱、已发送邮件同级）
• 务必移除On Error Resume Next，否则后续出现问题无法排查

内容的提问来源于stack exchange，提问作者ODT Team Member