Outlook Mailbox Backup to PST via vbscript

Following the post 21811473 regarding Outlook archiving, I was attempting to backup my mailbox using this script but was getting an error on the following line:

Set flr = ns.Folders(szDir)

I am assuming that it cannot find my PST file or my maillbox?

Basically all I want to do using the vbscript below or one similar, is to copy all items in my mailbox folders to a PST folder with a matching folder structure. I have created a PST and have created the same folders (Inbox, tasks etc) that are in my mailbox. I want to run this script every night as a backup so it is not important to work out the date of the items etc although it may be useful to check if they already exist in the pst file first before copying!

Can anyone help me?

Much appreciated!

JG.

Here is the script:

As to the VBScript, something like this should get the job done.  Copy and paste the code below into Notepad.  Edit it as needed, I included comments where theings can/need to be changed.  Save the file with a .vbs extension.  Double-click on the file to run it.  You could also schedule the script to be run using Windows' built-in task scheduler.  This script is very simple and is really only intended to archive the Inbox.  A more useful script would archive all folders (e.g. Tasks, Calender, etc.).

Dim olkApp, olkNS, olkRootFolder, olkArchiveFolder, intAge
'Change the age as desired
intAge = 90
Set olkApp = CreateObject("Outlook.Application")
Set olkNS = olkApp.GetNamespace("MAPI")
olkNS.Logon
'Change the Outlook folder path on the next line to that of the folder where you want archiving to begin
Set olkRootFolder = OpenMAPIFolder("\Mailbox - Doe, John\Inbox")
'Change teh Outlook folder path on the next line to that of the folder where archived items will be moved to
Set olkArchiveFolder = OpenMAPIFolder("\Personal Folders\Inbox Archive")
ProcessFolder olkRootFolder
olkNS.Logoff
Set olkNS = Nothing
Set olkRootFolder = Nothing
Set olkArchiveFolder = Nothing
Set olkApp = Nothing
WScript.Echo "All done!"
WScript.Quit

Sub ProcessFolder(olkFolder)
    Dim olkSubFolder, olkItems, olkItem, intCounter
    Set olkItems = olkFolder.Items
    For intCounter = olkItems.Count To 1 Step -1
        Set olkItem = olkItems.Item(intCounter)
        If olkItem.ReceivedTime <= (Now - intAge) Then
            olkItem.Move olkArchiveFolder
        End If
    Next
    For Each olkSubFolder In olkFolder.Folders
        ProcessFolder olkSubFolder
    Next
    Set olkSubFolder = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
Start Free Trial