vba - 将电子邮件移动到不同的数据/PST 文件

Question

我编辑了一个我在网上找到的脚本，将电子邮件移动到各个文件夹。

我想更进一步，将电子邮件移动到单独的 PST 文件中的文件夹。

这将在 Outlook 2007 中运行。

宏源于这个名为“更新”的宏，是更清晰的版本:
http://jmerrell.com/2011/05/21/outlook-macros-move-email

我几乎可以肯定这个链接包含线索，但我没有正确应用它的经验:
http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/

我当前的宏允许将电子邮件移动到主 PST“收件箱”文件夹中的 3 个不同文件夹位置。

'Outlook VB Macro to move selected mail item(s) to a target folder
Sub MoveToFolder(targetFolder)
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim MoveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem

Set ns = Application.GetNamespace("MAPI")

'define path to the target folder; the following assumes the target folder
'is a sub-folder of the main Mailbox folder

'This is the original'
'Set MoveToFolder = ns.Folders("Mailbox").Folders(targetFolder)'
Set MoveToFolder = ns.GetDefaultFolder(olFolderInbox).Folders(targetFolder)


If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox ("No item selected")
    Exit Sub
End If

If MoveToFolder Is Nothing Then
    MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If

For Each objItem In Application.ActiveExplorer.Selection
    If MoveToFolder.DefaultItemType = olMailItem Then
        If objItem.Class = olMail Then
            objItem.Move MoveToFolder
        End If
    End If
Next

Set objItem = Nothing
Set MoveToFolder = Nothing
Set ns = Nothing

End Sub

Sub MoveToActive()
MoveToFolder ("Active")
End Sub

Sub MoveToAction()
MoveToFolder ("Action")
End Sub

Sub MoveToOnHold()
MoveToFolder ("OnHold")
End Sub

如何配置第四个选项以将电子邮件移动到不同 PST 内的文件夹？

例如，我想添加一个名为“存档”的额外按钮，当单击此特定按钮时，它会将电子邮件移动到单独的 PST 收件箱中的存档文件夹。

Sub MoveToArchive()
MoveToFolder ("Archive")
End Sub

Answer 1

这是一个老问题，但这里有一个对我有用的解决方案，从几个来源修改代码。您可以根据您的要求对其进行修改。

这允许用户选择任何文件夹，无论是在默认位置下，还是在另一个存档或 PST 文件中。如果用户在文件夹选择器中选择取消，则电子邮件将保存到默认的已发送邮件文件夹。

Private Sub Application_ItemSend(ByVal Item As Object, _
                                 Cancel As Boolean)
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    On Error Resume Next
    Set objNS = Application.Session
    If Item.Class = olMail Then
        Set objFolder = objNS.PickFolder

        'save to a folder under the default structure, main PST/archive
        If Not objFolder Is Nothing And IsInDefaultStore(objFolder) And objFolder.DefaultItemType = olMailItem Then
            Set Item.SaveSentMessageFolder = objFolder

        'save to a non-default, different PST/archive
        ElseIf Not IsInDefaultStore(objFolder) Then
            Set objFolder = GetFolderFromPath(objFolder.FolderPath)
            Set Item.SaveSentMessageFolder = objFolder

        'neither, just save to default sent items folder
        Else
            Set objFolder = objNS.GetDefaultFolder(olFolderSentMail)
            Set Item.SaveSentMessageFolder = objFolder
        End If
    End If
    Set objFolder = Nothing
    Set objNS = Nothing
End Sub

Public Function IsInDefaultStore(objOL As Object) As Boolean
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objInbox As Outlook.MAPIFolder
    Dim blnBadObject As Boolean
    On Error Resume Next
    Set objApp = objOL.Application
    If Err = 0 Then
        Set objNS = objApp.Session
        Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
        Select Case objOL.Class
            Case olFolder
                If objOL.StoreID = objInbox.StoreID Then
                    IsInDefaultStore = True
                Else
                    IsInDefaultStore = False
                End If
            Case olAppointment, olContact, olDistributionList, _
                 olJournal, olMail, olNote, olPost, olTask
                If objOL.Parent.StoreID = objInbox.StoreID Then
                    IsInDefaultStore = True
                Else
                    IsInDefaultStore = False
                End If
            Case Else
                blnBadObject = True
        End Select
    Else
        blnBadObject = True
    End If
    If blnBadObject Then
        'if cancel is selected then just leave in sent items, so do nothing.
'        MsgBox "This function isn't designed to work " & _
'               "with " & TypeName(objOL) & _
'                " objects and will return False.", _
'                , "IsInDefaultStore"
        IsInDefaultStore = False
    End If
    Set objApp = Nothing
    Set objNS = Nothing
    Set objInbox = Nothing
End Function

'modified from https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
Function GetFolderFromPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderFromPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderFromPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function