Move emails to a different data/PST file
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
Admin
Updated on June 28, 2022Comments
-
Admin almost 2 years
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-emailI'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
-
Admin over 10 yearsThanks for the help so far. Excuse my newbie status but can you help me understand better exactly where to place this code, and if it need to replace another portion of code? I tried a few different scenario's and when I click it does nothing. Does "name of pst" need to be the full name, as in "archive.pst", and if I would like it to go into a secondary folder that is located within the "Inbox" folder can you help understand how to do that? My goal is to keep the existing buttons working as is within the main Data PST, and then have an additional button for the archive. I appreciate the help!
-
niton over 10 yearsRemove On Error resume next. Copy the entire code replace all instances of MoveToFolder with MoveToFolderInPST. The name of the pst is what you see in the navigation pane. Sub MoveToArchive() MoveToFolderInPST ("Archive") End Sub