Folder path to enterprise vault using VBA for email migration

user_10375515 0
Viewed 396

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like

Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")

but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.

Sub Sort_Test(Item)
    Dim Msg As Object
    Dim Appt As Object
    Dim Meet As Object
    Dim olApp As Object
    Dim objNS As Object
    Dim targetFolder As Object

    On Error GoTo ErrorHandler

 Set Msg = Item
    Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
    checksub = Msg.Subject
    checksend = Msg.Sender
    checksendname = Msg.SenderName
    checksendemail = Msg.SenderEmailAddress
    checkbod = Msg.Body
    checkto = Msg.To
    checkbcc = Msg.BCC
    checkcc = Msg.CC
    checkcreation = Msg.CreationTime
    checksize = Msg.Size

'Classes Folder
        If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
        Or checksend Like "*Award*eBooks*" Then
                Set targetFolder = PST.Folders("Education").Folders("Classes")
                Msg.Move targetFolder
                GoTo ProgramExit
        End If

If targetFolder Is Nothing Then
        GoTo ProgramExit
'    Else
'        Msg.Move targetFolder
    End If

'    Set olApp = Nothing
'    Set objNS = Nothing
    Set targetFolder = Nothing
    Set checksub = Nothing
    Set checksend = Nothing


ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub
office365 outlook vba
1 Answers

Try this code:

Sub MoveToFolder()

Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")


For M = 1 To olArcFolder.items.Count
    Set myItem = olArcFolder.items(M)
    myItem.Display
    Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
    Set myCopiedInspectors = myInspectors.copy
    myCopiedInspectors.Move olCompFolder
    myInspectors.Close olDiscard
Next M

Here is a link for you reference:

Do for all open emails and move to a folder

user_101845850
Related