VBA to move selected emails or conversation to current year pst folder

webharvest · #1 08-14-2015, 04:18 PM

I just upgraded to Outlook 2013. I had some vba code to move selected emails to a reference pst folder by year. So how it worked was it would look at the date on the emails I had selected when I ran the macro and it would store it in a reference pst folder that I would create at the beginning of every year (2015_Reference_Files). Now that I'm running Outlook 2013 the macro runs but doesn't move the files. I'm hoping someone knows what the new syntax is for Outlook 2013. Ideally I would like it to move all the files in a conversation if I have a conversation selected and also work if I have a number of emails selected. I'm new to outlook 2013 and the conversation view.

Any help would be greatly appreciated. Below is the code I had before.

Code:

Sub MoveSelectedMessagesToCurrentPST()
    MoveSelectedMessagesToPSTFolder (Year(Now()) & "_Reference_Files")
End Sub

Sub MoveSelectedMessagesToPSTFolder(PSTName As String) ', FolderName As String
On Error Resume Next
'On Error Resume Next
'    Dim objFolder As Outlook.MAPIFolder
'    Dim objInbox As Outlook.MAPIFolder
'    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
    
'    Dim objTopFolder As Outlook.MAPIFolder
'    Dim objNextFolder As Outlook.MAPIFolder
    Dim objTargetFolder As Outlook.MAPIFolder
    Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem


'    Set objNS = Application.GetNamespace("MAPI")
'    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
'    Set objFolder = objInbox.Folders(PST_FolderName)


    Set objNS = Application.GetNamespace("MAPI")
'    Set objTopFolder = objNS.Folders(PSTName).Folders(FolderName)
'    Set objNextFolder = objTopFolder.Folders("Systems")
'    Set objTargetFolder = objNextFolder.Folders("Outlook")
    Set objTargetFolder = objNS.Folders(PSTName) '.Folders(FolderName)
    
'Assume this is a mail folder
    If objTargetFolder Is Nothing Then
        MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If
    
    If Application.ActiveExplorer.Selection.Count = 0 Then
        'Require that this procedure be called only when a message is selected
        Exit Sub
    End If
        If Application.ActiveExplorer.Selection(1).Class = 43 Then
    ' 43 is the literal constant for a mail item
    ' sometimes a calendar item is in the inbox, in which case there is a type
    ' conflict with the objItem variable, which is declared as a mail item.
        For Each objItem In Application.ActiveExplorer.Selection
            If objFolder.DefaultItemType = olMailItem Then
                If objItem.Class = olMail Then
                    objItem.UnRead = False
                    objItem.Move objTargetFolder
                End If
            End If
        Next
    Else
        MsgBox ("This is not a message; it may be a calendar request")
    End If
    
    Set objItem = Nothing
    Set objFolder = Nothing
'    Set objInbox = Nothing
    Set objNS = Nothing
    
 End Sub

gmayor · #2 08-15-2015, 01:55 AM

If you preface your code modules with

Code:

Option Explicit

You will be forced to declare your variables and that would demonstrate that you have an important one undeclared and unconfigured.

The following modification establishes whether the required target folder is present and if not creates it in the Windows folder indicated. Make this folder the same folder that your main PST is stored in. As for the rest, I have removed some of the complexity of your conditional statements some of which are superfluous. I have not tested it in Outlook 2013, but I cannot see any reason why it should not work, and it certainly works in Outlook 2010.

Code:

Option Explicit

Sub MoveSelectedMessagesToCurrentPST()
    MoveSelectedMessagesToPSTFolder (Year(Now()) & "_Reference_Files")
End Sub

Sub MoveSelectedMessagesToPSTFolder(PSTName As String)        ', FolderName As String
'On Error Resume Next
Const strStorePath As String = "C:\Path\" 'The location of the PST file

Dim objTargetFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim olFolder As Outlook.MAPIFolder
Dim bFolder As Boolean
    On Error Resume Next
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "Nothing selected"
        GoTo lbl_Exit
    End If
    On Error GoTo 0
    Set objNS = Application.GetNamespace("MAPI")
    For Each olFolder In objNS.folders
        If olFolder.Name = PSTName Then
            bFolder = True
            Set objTargetFolder = olFolder
            Exit For
        End If
    Next olFolder

    If Not bFolder Then
        MsgBox "The folder '" & PSTName & "' doesn't exist!" & vbCr & vbCr & _
               "Creating new folder", vbOKOnly + vbExclamation, "Missing Folder"
        objNS.AddStore strStorePath & PSTName & ".pst"
        Set objTargetFolder = objNS.folders.GetLast
        objTargetFolder.Name = PSTName
    End If

    For Each objItem In Application.ActiveExplorer.Selection
        If objItem.Class = olMail Then
            objItem.UnRead = False
            objItem.Move objTargetFolder
        End If
    Next

lbl_Exit:
    Set objNS = Nothing
    Set objTargetFolder = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Move emails from one folder to another	smiler44	Outlook	9	11-20-2014 03:02 PM
Outlook VBA to move selected email to a public folder	aaroncrt	Outlook	2	10-21-2013 05:11 PM
Move conversation to folder after replying	karlads	Outlook	0	01-28-2012 12:52 PM
How to call current PC date and/or current PC year	KIM SOLIS	Excel	2	11-04-2011 06:09 PM
Auto insert current month's name and current year	Styler001	Word	4	01-25-2010 06:40 PM