Move all Items from a PST file

3
votes

Its eventually gotten to the point where I have to ask for help.

It was common practice in our company to take backups of mail/calendar etc from outlook to PST files due to space restrictions on the email server.

We no longer have space restrictions that prevevnt this on the email server now, so we would like to get all of the info in the PST files into the users mailbox.

Eventually we are hoping to run a vbscript or similar that would search the users local drives, discover any PST files, and then transfer all of the data to the exchange mailbox under a folder called "Imported" and then delete the PST.

Ideally we would just do this through PShell directly to Exchange without the user, but as most users have "many" PST files, most of them not required, and would fill up our exchange if we did them all.

I do not know Outlook VBA at all, so that is the only part I need help with. I have spend a while working my way through search results hoping to see I can get this working, but cannot get it working.

I have had several different tries at this. This is the current code I have:

' Get the main Inbox folder
Const OLInbox = 6    'Inbox Items folder
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNameSpace = objOutlook.GetNamespace( "MAPI" )

Set objInbox = objNameSpace.GetDefaultFolder( OLInbox ) 'sets objFolder to the Inbox for it's reference 

' Create the Imported folder in the main inbox
On Error Resume Next
Set objDestFolder = objInbox.Folders( "Imported" )
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
End If
On Error Goto 0



' Add the PST to Outlook
objNamespace.AddStore ("d:\backup.pst")

' Select the new store
Set objPST = objNamespace.Folders.GetLast
' Rename the Store To be easier To use
objPST.Name = "PSTImport"

' disconnect and reconnect the store to force a refresh of the folder list
objNamespace.RemoveStore objPST
objNamespace.AddStore ("d:\backup.pst")


Set objPSTInbox = objOutlook.Session.Folders("PSTImport").Folders("Inbox")

'Set objPSTFolder = objNameSpace.Folders("PSTImport").Folders("Inbox")
Set objPSTItems = objPSTInbox.Items

While TypeName(objPSTItems) <> "Nothing"
    objPSTItems.Move objDestFolder
    Set objPSTItems = objPSTItems.FindNext
Wend

Currently the full script looks like this

Set objShell = WScript.CreateObject ("WScript.Shell")

' Get the main Inbox folder
Const OLInbox = 6    'Inbox Items folder
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNameSpace = objOutlook.GetNamespace( "MAPI" )

Set objInbox = objNameSpace.GetDefaultFolder( OLInbox ) 'sets objFolder to the Inbox for it's reference 

' Create the Imported folder in the main inbox
On Error Resume Next
Set objDestFolder = objInbox.Folders("Imported")
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
    Set objDestFolder = objInbox.Folders("Imported")
End If
On Error Goto 0



' Add the PST to Outlook
objNamespace.AddStore ("d:\backup.pst")

' Select the new store
Set objPST = objNamespace.Folders.GetLast
' Rename the Store To be easier To use
objPST.Name = "PSTImport"

' disconnect and reconnect the store to force a refresh of the folder list
objNamespace.RemoveStore objPST
objNamespace.AddStore ("d:\backup.pst")


Set objPSTInbox = objOutlook.Session.Folders("PSTImport").Folders("Inbox")

Set objPSTInboxItems = objPSTInbox.Items
PSTInboxItemsCount = objPSTInboxItems.count

For i = PSTInboxItemsCount To 1 Step -1
    objPSTInboxItems(i).Move objDestFolder
Next

Upon testing, the Imported folder is created in the Inbox successfully.

The PST is added as a store and the rename works fine too.

However, it appears to be the loop/Next part of the scrip that fails. No items are moved over to the Imported folder.

I think we may not be selecting the items within the mailbox. Do we need to specify another "folders()" section in there?

Ideally we would want to move over any office content in the PST. Does anyone know if Calendar entries would be copied over as part of this.

Would we need to specify for example, get all mails and move then get all contacts and move, get all calendar entries and move?

2
vbaoutlook

2 Answers

2
votes

"cannot get it working" You have not described the problem(s) but here are some suggestions.

Add a line to set objDestFolder when creating the folder.

On Error Resume Next
Set objDestFolder = objInbox.Folders("Imported")
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
    Set objDestFolder = objInbox.Folders("Imported")
End If
On Error Goto 0

Or always attempt to create the Imported folder in the main inbox

' Bypass the error if the folder exists
On Error Resume Next
Set objDestFolder = objInbox.Folders.add("Imported")
On Error GoTo 0
Set objDestFolder = objInbox.Folders("Imported")

Replace the While Wend with something like this.

For i = PSTInboxItemsCount To 1 Step -1
    objPSTInboxItems(i).Move objDestFolder
Next i
2
votes

Got it working

Set objShell = WScript.CreateObject ("WScript.Shell")

' Get the main Inbox folder
Const OLInbox = 6    'Inbox Items folder
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNameSpace = objOutlook.GetNamespace( "MAPI" )

Set objInbox = objNameSpace.GetDefaultFolder( OLInbox ) 'sets objFolder to the Inbox for it's reference 

' Create the Imported folder in the main inbox
On Error Resume Next
Set objDestFolder = objInbox.Folders("Imported")
If Err.Number <> 0 Then
    Set objNewFolder = objInbox.Folders.Add("Imported")
    Set objDestFolder = objInbox.Folders("Imported")
End If
On Error Goto 0


' Run the sub
sbImportPST ("d:\backup.pst")


Sub sbImportPST (strPSTLocalPath)
    ' Add the PST to Outlook
    objNamespace.AddStore (strPSTLocalPath)

    ' Select the new store
    Set objPST = objNamespace.Folders.GetLast
    ' Rename the Store To be easier To use
    objPST.Name = "PSTImport"

    ' disconnect and reconnect the store to force a refresh of the folder list
    objNamespace.RemoveStore objPST
    objNamespace.AddStore (strPSTLocalPath)

    ' Get the mail items in the top level - in most cases this will not be needed as mails will be in the "inbox" folder under this folder
    Set objPSTInbox = objOutlook.Session.Folders("PSTImport")
    Set objPSTInboxItems = objPSTInbox.Items
    PSTInboxItemsCount = objPSTInboxItems.count
    ' Step through all items just discovered and move to Imported Folder
    For i = PSTInboxItemsCount To 1 Step -1
        objPSTInboxItems(i).Move objDestFolder
    Next 

    ' Step through all subfolders of the PST (this wilkl include the folder "calendar" and "contacts" and "Inbox") and move the folder.
    Set oFolders = objPSTInbox.Folders 
    For i = oFolders.Count To 1 Step -1 
        oFolders.Item(i).MoveTo  objDestFolder
    Next 

    ' Remove the PST file from Outlook
    objNamespace.RemoveStore objPST
End Sub