Microsoft Office Forums - View Single Post - [Solved] VBA to move selected emails or conversation to current year pst folder

gmayor · 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