如何将已分类邮件自动移动至指定PST文件文件夹？

需求说明 #

上司收到大量邮件，已分配分类的邮件需要自动移动到对应分类名称的其他PST文件收件箱（无需自动创建收件箱）。现有代码仅支持移动到默认收件箱内的子文件夹，需调整以适配POP3协议下的多PST场景（因历史误删邮件问题，不切换IMAP）。

修改后的VBA代码 #

Private WithEvents objInboxFolder As Outlook.Folder
Private WithEvents objInboxItems As Outlook.Items

' 获取指定PST存储对象的辅助函数
Private Function GetTargetPSTStore(ByVal pstDisplayName As String) As Outlook.Store
    Dim objStore As Outlook.Store
    For Each objStore In Outlook.Application.Session.Stores
        ' 匹配PST的显示名称（需替换为你实际的PST名称）
        If objStore.DisplayName = pstDisplayName Then
            Set GetTargetPSTStore = objStore
            Exit Function
        End If
    Next objStore
    Set GetTargetPSTStore = Nothing
End Function

' 初始化监听默认收件箱
Private Sub Application_Startup()
    Set objInboxFolder = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set objInboxItems = objInboxFolder.Items
End Sub

' 邮件分类变更时执行移动逻辑
Private Sub objInboxItems_ItemChange(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    Dim objTargetStore As Outlook.Store
    Dim objTargetInbox As Outlook.Folder
    Dim objTargetFolder As Outlook.Folder
    
    ' 替换为你的目标PST显示名称，比如"归档PST"
    Const TARGET_PST_NAME As String = "你的目标PST显示名称"
    
    If TypeOf Item Is MailItem Then
        Set objMail = Item
        
        ' 获取目标PST存储
        Set objTargetStore = GetTargetPSTStore(TARGET_PST_NAME)
        If objTargetStore Is Nothing Then
            MsgBox "未找到指定的PST文件：" & TARGET_PST_NAME, vbExclamation
            Exit Sub
        End If
        
        ' 获取目标PST的收件箱
        Set objTargetInbox = objTargetStore.GetDefaultFolder(olFolderInbox)
        
        ' 根据分类移动邮件到对应PST收件箱的子文件夹
        If InStr(objMail.Categories, "Followup") > 0 Then
            Set objTargetFolder = objTargetInbox.Folders("Followup")
            objMail.Move objTargetFolder
        ElseIf InStr(objMail.Categories, "Business") > 0 Then
            Set objTargetFolder = objTargetInbox.Folders("Business")
            objMail.Move objTargetFolder
        End If
    End If
End Sub

关键改动说明 #

1. 新增GetTargetPSTStore辅助函数：遍历Outlook中所有已加载的存储文件（PST/OST），通过PST的显示名称定位目标存储（你需要在代码中替换TARGET_PST_NAME为实际的PST名称，比如Outlook左侧导航栏里显示的PST名称）。
2. 切换目标收件箱来源：不再使用默认收件箱，而是从指定PST存储中获取其收件箱，再定位到对应分类的子文件夹。
3. 增加错误检查：如果找不到指定PST，弹出提示避免代码崩溃。

注意事项 #

• 确保目标PST中已经存在对应分类名称的子文件夹（比如"Followup"、"Business"），代码不会自动创建文件夹。
• POP3协议下，邮件移动后默认收件箱的邮件会被移除（符合POP3本地存储特性），如果需要保留副本，可在移动前添加objMail.Copy逻辑。

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