How can I export all folders to .pst file? RRS feed

  • Question

  • Hi.

    How can I automatically export all mail folders from Outlook 2013 application to .pst file using PS\VBS\VBA?

    I found this via Google, but it is not working for Outlook 2013:

    'Create a constant'
        Const olFolderInbox = 6
    'Create some variables'
        Dim strBackupPath, strBackupFileName
        Dim objShell
        Dim olkApp, olkSes, olkRootFolder, olkFolder, olkFolderCopy, olkBackup
    'Initialize variables'
    	Set myFSO = CreateObject("Scripting.FileSystemObject")
    	Set WriteStuff = myFSO.OpenTextFile("C:\MIGRATION.LOG", 8, True)
        Set objShell = CreateObject("WScript.Shell")
        Set olkApp = CreateObject("Outlook.Application")
        Set olkSes = olkApp.GetNamespace("MAPI")
        strBackupFileName = "MIGRATION_2011"
        strBackupPath = "C:\Outlook\"
    'Connect to Outlook'
    'Create a new PST file'
        olkSes.AddStore strBackupPath & strBackupFileName & ".pst"
        Set olkBackup = OpenOutlookFolder("Personal Folders")
        olkBackup.Name = strBackupFileName
        olkSes.RemoveStore olkBackup
        olkSes.AddStore strBackupPath & strBackupFileName & ".pst"
        Set olkBackup = OpenOutlookFolder(strBackupFileName)
    'Back-up exisiting folders to the new PST file'
        Set olkRootFolder = olkSes.GetDefaultFolder(olFolderInbox).Parent
        For Each olkFolder In olkRootFolder.Folders
            Set olkFolderCopy = olkFolder.CopyTo(olkBackup)
    'Close and remove the back-up PST file'
        olkSes.RemoveStore olkBackup
    'Disconnect from Outlook'
    'Destroy objects to avoid memory leaks'
        Set objShell = Nothing
        Set olkSes = Nothing
        Set olkApp = Nothing
        Set olkBackup = Nothing
        Set olkRootFolder = Nothing
        Set olkFolder = Nothing
        Set olkFolderCopy = Nothing
    'Terminate script processing
    	Stuff = "Outlook Backed Up:"  
    Function OpenOutlookFolder(strFolderPath)
        ' Purpose: Opens an Outlook folder from a folder path.'
        ' Written: 4/24/2009'
        ' Author:  BlueDevilFan'
        ' Outlook: All versions'
        Dim arrFolders, varFolder, bolBeyondRoot
        On Error Resume Next
        If strFolderPath = "" Then
            Set OpenOutlookFolder = Nothing
            Do While Left(strFolderPath, 1) = "\"
                strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
            arrFolders = Split(strFolderPath, "\")
            For Each varFolder In arrFolders
                Select Case bolBeyondRoot
                    Case False
                        Set OpenOutlookFolder = olkSes.Folders(varFolder)
                        bolBeyondRoot = True
                    Case True
                        Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                End Select
                If Err.Number <> 0 Then
                    Set OpenOutlookFolder = Nothing
                    Exit For
                End If
        End If
        On Error GoTo 0
    End Function

    Requesting any assistance, thank you!

    • Edited by longailend Friday, December 4, 2015 10:23 AM mistake
    Friday, December 4, 2015 10:10 AM


All replies

  • Hello,

    Looks like you need to specify the correct folder name to the OpenOutlookFolder function. Seems like there is no Personal Folders folder:

    Set olkBackup = OpenOutlookFolder("Personal Folders")

    You may consider using the GetRootFolder method of the Store class instead. The method returns a Folder object representing the root-level folder of the Store.

    You can use the GetRootFolder method to enumerate the subfolders of the root folder of the Store. Unlike NameSpace.Folders which contains all folders for all stores in the current profile, Store.GetRootFolder.Folders allows you to enumerate all folders for a given Storeobject in the current profile.

    Sub EnumerateFoldersInStores() 
     Dim colStores As Outlook.Stores 
     Dim oStore As Outlook.Store 
     Dim oRoot As Outlook.Folder 
     On Error Resume Next 
     Set colStores = Application.Session.Stores 
     For Each oStore In colStores 
     Set oRoot = oStore.GetRootFolder 
     Debug.Print (oRoot.FolderPath) 
     EnumerateFolders oRoot 
    End Sub 
    Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder) 
     Dim folders As Outlook.folders 
     Dim Folder As Outlook.Folder 
     Dim foldercount As Integer 
     On Error Resume Next 
     Set folders = oFolder.folders 
     foldercount = folders.Count 
     'Check if there are any folders below oFolder 
     If foldercount Then 
     For Each Folder In folders 
     Debug.Print (Folder.FolderPath) 
     EnumerateFolders Folder 
     End If 
    End Sub

    Also you may find the How to: Enumerate Folders article helpful.

    Friday, December 4, 2015 10:41 AM
  • Thank you.

    FFinally made it using AutoIt and OutlookEX UDF.

    • Proposed as answer by David_JunFeng Tuesday, December 8, 2015 1:27 AM
    • Marked as answer by David_JunFeng Tuesday, December 15, 2015 1:41 AM
    Monday, December 7, 2015 8:46 AM