Move emails to a different data/PST file

Question

I have edited a script I found online to move email to various folders.

I want to take it a step further to move emails to a folder within a separate PST file.

This will be running in Outlook 2007.

The macro stems from this Macro that is titled "Updated" and is the cleaner version:
http://jmerrell.com/2011/05/21/outlook-macros-move-email

I'm almost certain this link holds the clue, but I don't have the experience to apply it properly:
http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/

My current Macro allows emails to be moved to 3 different folder locations within the main PST "Inbox" folder.

'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

---

How do I configure a 4th option to move an email to a folder within a different PST?

For example I would like to add an extra button called "Archive", and when this particular button is clicked it will move the email to the archive folder within the separate PST's Inbox.

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

Answer 1

This is an old question, but here is a solution that works for me, modifying code from a few sources. You can modify it to your requirement.

This allows the user to select any folder, either under the default locations or even in another archive or PST file. If the user selects Cancel in the folder picker, then the email is saved to the default sent mail folder.

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

Answer 2

Try this format commented out in the code above.

Sub MoveToFolderInPST(targetFolder)
    '...
    Set MoveToFolderInPST = ns.Folders("name of pst").Folders("Inbox").Folders(targetFolder)

Answer 3

Maybe this will work for what you need. Function SeekFolder() will return the folder or nothing case it doesnt find it.

Public Function SeekFolder(ByVal SearchName As String) As Folder
    Dim FoundFolder As Folder
    For Each RF In Session.Folders
        Set FoundFolder = RecursiveSearch(RF, SearchName)
        If Not FoundFolder Is Nothing Then
            If FoundFolder = SearchName Then
                Set SeekFolder = FoundFolder
                Exit Function
            End If
        End If
    Next RF
End Function

Private Function RecursiveSearch(ByVal RF As Folder, ByVal SearchName As String) As Folder
    If RF.Folders.Count <= 0 Then Exit Function
    For Each f In RF.Folders
        If LCase(f) = LCase(SearchName) Then
            Set RecursiveSearch = f
            Exit Function
        End If
        If f.Folders.Count > 0 Then RecursiveSearch f, SearchName
    Next f
End Function