Logon Script: Move Local PST Files To Network Share

Download Script: move-pst-to-network.zip

So, my buddy (and former co-worker) called me yesterday for some help with a script he put together.  His script checked the local profile in Outlook for any PST files that were stored locally.  If it found any, it would them move them to the users home space.  We tried and tried to get the script to work properly but it never seemed to work 100%.  Being that he is a good friend and this would be useful at work, I decided to take the work he had put in and get the thing working.

Here is what the script does:

  1. Checks to see if the computer is a laptop.  If it is, the user probably uses Outlook offline and/or over VPN so moving the PST to a network share will be detrimental to the user’s experience.  If you don’t care, just comment out lines 17-21.
  2. Checks to see if Outlook is installed and can be launched properly.  If it can not, no sense in continuing the script.  It will exit.
  3. Checks to see that the target (network) directory exists and is writable.  If it does not exist or is not writable, the script will exit.
  4. Enumerates all the local stores and returns all the PST files.
  5. Check to see if the PST files are stored on local drives.  It will exclude drives that are mapped network drives and/or removable media.
  6. Check if a file already exists in the target directory with the same name.  If one does, it will not copy the file over. (I may update the script to move and rename the file to ensure all local PSTs are moved.
  7. Removes all Personal Folders from Outlook that matched criteria.
  8. Moves actual PST files to network share (Outlook will close to release the file lock on the PST file).
  9. Adds all the Personal Folders back to Outlook.

I have tested this on Windows XP w/ Office 2007 and Office 2003.  I am interested in hearing if this works or not in your environment.  I hope you find this useful.

'==========================================================================
' VBScript Source File
' NAME: move-pst-to-network
' AUTHOR: Andrew J Healey & Nate Stevenson
' WEB: https://www.healey.io/
' DATE  : 2010.14.2009
' COMMENT: This script will move any mapped PST files that are located on
'	local disks to a network share.
' PROCESS: 1) determine if laptop; 2) determine if outlook installed
'	3) determine local drives; 4) check for local pst's; 5) move pst's
'	to network; 6) remap pst files
'==========================================================================

Option Explicit

'Determine if a laptop (remove if you don't care)
If IsLaptop() = True Then
	wscript.echo "Computer is a laptop or the chassis could not be determined."
	wscript.echo "Exiting."
	wscript.quit
End If

'Determine if outlook is installed
If IsOutlookInstalled() = False Then
	wscript.echo "Could not launch Outlook."
	wscript.echo "Exiting."
	wscript.quit
End If

'Get user name
Dim WshNetwork : Set WshNetwork = WScript.CreateObject("WScript.Network")
Dim user : user = lcase(WshNetwork.UserName)
Set WshNetwork = Nothing

Dim strNetworkPath
'=========================================================================
' Configuration Section
strNetworkPath = "\servernamehomes" & user & ""
' End Configuration Section
'=========================================================================
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "" Then strNetworkPath = strNetworkPath & ""

'Determine if network path is writable
If IsPathWritable(strNetworkPath) = False Then
	wscript.echo "Remote path is not writable."
	wscript.echo "Exiting."
	wscript.quit
End If

'Instatiate objects
Dim objOutlook, objNS, objFSO, objFolder
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Sort through all stores in outlook and add all local pst
' paths into an array. Then remove the store from outlook.
Dim pstFiles
Dim count : count = -1
Dim arrPaths()
For Each objFolder In objNS.Folders
	If GetPSTPath(objFolder.StoreID) <> "" Then
		pstFiles = GetPSTPath(objFolder.StoreID)
		If IsStoredLocal(pstFiles) = True Then
			If objFSO.FileExists(strNetworkPath & Mid(pstFiles,InStrRev(pstFiles,"") + 1)) = True Then
				wscript.echo "A pst file already exists with the same name." & vbCrLf & _
						vbTab & "Source: " & pstPath & vbCrLf & _
						vbTab & "Target: " & strNetworkPath & Mid(pstPath,InStrRev(pstPath,"") + 1)
			Else
				count = count + 1
				ReDim Preserve arrPaths(count)
				arrPaths(count) = pstFiles
				objOutlook.Session.RemoveStore objFolder
			End If
		End If
	End If
Next

objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing

if count < 0 then
	wscript.echo "No local PST Files Found."
	wscript.quit
End If

'If local PST files were found, move them to the new location
' Echo output if the file already exists
Dim pstPath
For Each pstPath in arrPaths
	On Error Resume Next
		objFSO.MoveFile pstPath, strNetworkPath
		If Err.Number <> 0 Then
			wscript.sleep 5000
			objFSO.MoveFile pstPath, strNetworkPath
		End If
	Err.Clear
	On Error GoTo 0
Next
Set objFSO = Nothing

'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")

'Re-map Outlook folders
For Each pstPath in arrPaths
	objNS.AddStore strNetworkPath & Mid(pstPath,InStrRev(pstPath,"") + 1)
Next

objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
wscript.echo "Done."
wscript.quit

Private Function GetPSTPath(byVal input)
	'Will return the path of all PST files
	' Took Function from: http://www.vistax64.com/vb-script/
	Dim i, strSubString, strPath
	For i = 1 To Len(input) Step 2
		strSubString = Mid(input,i,2)
		If Not strSubString = "00" Then
			strPath = strPath & ChrW("&H" & strSubString)
		End If
	Next

	Select Case True
		Case InStr(strPath,":") > 0
			GetPSTPath = Mid(strPath,InStr(strPath,":")-1)
		Case InStr(strPath,"\") > 0
			GetPSTPath = Mid(strPath,InStr(strPath,"\"))
	End Select
End Function

Private Function IsLaptop()
	'Determine if the computer is a mobile machine
	On Error Resume Next
		'Instantiate objects
		Dim objWMIService, colChassis, objChassis, strChassisType
		Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootcimv2")
		Set colChassis = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")

		'Check chassis type
		'http://msdn.microsoft.com/en-us/library/aa394474%28VS.85%29.aspx
		For Each objChassis in colChassis
			For  Each strChassisType in objChassis.ChassisTypes
				If (strChassisType >= 8 And strChassisType <=12) Or (strChassisType = 14) Then
					IsLaptop = True
					Exit For
				Else
					IsLaptop = False
				End If
			Next
		Next
	If Err.Number <> 0 Then IsLaptop = False
	On Error GoTo 0
	Set colChassis = Nothing
	Set objWMIService = Nothing
	objChassis = Null
End Function 

Private Function IsOutlookInstalled()
	'Function will return false if unable to launch outlook
	' This adds some overhead but it is ultimately the best
	' way to truly determine if script will function properly.
	On Error Resume Next
		Set objOutlook = CreateObject("Outlook.Application")
		If Err.Number <> 0 Then
			IsOutlookInstalled = False
			Exit Function
		End If
	On Error GoTo 0
	IsOutlookInstalled = True
	objOutlook.Session.Logoff
	objOutlook.Quit
	Set objOutlook = Nothing
End Function

Private Function IsPathWritable(byVal strPath)
	'Check to make sure the path is writable. If it is not, no
	' need to continue processing.
	On Error Resume Next
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Dim min : min = 1
		Dim max : max = 1000
		Dim rand : rand = Int((max - min + 1) * Rnd + min)
		Dim fullFileName : fullFileName = strPath & "temporary-" & rand & ".txt"
		Dim objFile : Set objFile = objFSO.CreateTextFile(fullFileName, True)
		objFile.WriteLine("Test file creation of " & fullFileName)
		objFile.Close
		If objFSO.FileExists(fullFileName) Then
			IsPathWritable = True
			objFSO.DeleteFile(fullFileName)
		Else
			IsPathWritable = False
		End If
	If Err.Number <> 0 Then IsPathWritable = False
	On Error GoTo 0
	Set objFile = Nothing
	Set objFSO = Nothing
	rand = Null
	max = Null
	min = Null
	fullFileName = Null
End Function

Private Function IsStoredLocal(ByVal fullFileName)
	'Check if the PST is stored locally or on a mapped or removable drive
	On Error Resume Next
		Dim objDisk, objWMIService, colDisks
		Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootcimv2")
		Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_LogicalDisk")
		For Each objDisk in colDisks
			If objDisk.DriveType = 3 Then
				If InStr(fullFileName,objDisk.DeviceID) > 0 Then
					IsStoredLocal = True
					Exit For
				Else
					IsStoredLocal = False
				End If
			End If
		Next
	If Err.Number <> 0 Then IsLocalDrive = False
	On Error GoTo 0
End Function

22 comments

  1. Hi Andrew,

    I’ve been looking for something like this to do exactly the same thing on our network.

    I’ve made a few changes, so that it will work exactly how we want and also create a log file of what’s happened. The script works great, apart from one important thing that I’m stuck on..

    It will move only the first PST it comes across in Outlook each time it is run. It doesn’t seem to either want to read the others in to the array or read others from the array.

    My VBS skills are really weak (although getting better quickly!). I wondered if you could shed any light on this?

    Many thanks, and well done on a great script!

    Mark.

    1. Hi Mark,
      We too experienced similar issues. However, we rewrote our original script and ended up with the one above which hasn’t given us the same grief as the original did. There are three main actions that occur in the script above:
      1. Delete local stores
      2. Move files
      3. Add local stores back
      Play around with pauses. It seems to make a world of difference. We found the issue seemed to be related to latency either on the system or on the network. Putting in more pauses fixed the issue (see line 98). Try adding a pause on line 105 and/or line 85.

  2. Hi Andrew,

    Your vbscript is amazing!

    I’m having a slight issue with Outlook 2007. Currently, all of our workstations have the “Personal Folders” as the default mail folder in which all emails flow into. Whenever I run your script up to line 75 ( objOutlook.Session.RemoveStore objFolder), I get the following error message:

    “You cannot close the mailbox that contains your calendar, contacts, and inbox.

    Is there are way to force removal of that “Personal Folders”?

    I really appreciate your help!
    Thank you very much,
    Bao Tran

    1. Hi Andrew,
      I am having the same issue as the Microsoft Guy.
      the problem happens when you try to move a PST file that is already the default mail folder.
      do you have a tweak to fix this issue? thanks again

  3. Hi Andrew,

    Great script ! I made a few changes to make it work like I want to.

    I noticed a bug in your script though. It appears when a user has more than one PST mounted in Outlook. When you remove the folder in the For Each loop, the collection of objNS.Folders is modified (the folder object is removed from the collection) and it causes the loop to stop. It results in the second PST not being moved.

    To solve this problem, I had to put the folder in another array instead of removing it in the For Each loop then loop through this array and remove the folder from Outlook. I can send you my version of the code if you want.

    Many thanks for your script.

    1. Hi Sebcou,

      How can i get your version of the script, i’m having the same issues your having

      Thank you

  4. Hi Sebcou,

    How can i get your version of the script, i’m having the same issues your having

    Thank you

  5. Hello,

    in my case the script in here:
    if (strChassisType >= 8 And strChassisType <=12) Or (strChassisType = 14) Then

    Actually I am looking for a script to place back .pst files from network share to user profile.
    Can you help me with that?
    You script is amazing but I have some problems with it.

    Regards,
    Peter

  6. Hi sebcou,

    I’m also interesseted in your version of this great script. I’m experiencing the same trouble as you and Guido do.
    Could you sent me your version?

    Many thanks.

  7. Did Sebcou ever send out his updated script? Having the same problem where it will only move one PST per script run. Also anybody else have a solution for archive files that have the same file name?

  8. http://stackoverflow.com/questions/6414189/move-pst-files-to-server-via-vb

    Read answer :

    ‘ Enumerate PST filesand build arrays
    objTextFile.Write(“Enumerating PST files” & vbCrLf)
    For Each objFolder in objNS.Folders
    If GetPSTPath(objFolder.StoreID) “” Then
    count = count + 1
    pstFiles = GetPSTPath(objFolder.StoreID)
    pstName = objFolder.Name
    pstFolder = objFolder
    objTextFile.Write(count & ” ” & pstFiles & vbCrLf)
    ReDim Preserve arrNames(count)
    arrNames(count) = pstName
    ReDim Preserve arrPaths(count)
    arrPaths(count) = pstFiles
    ‘objOutlook.Session.RemoveStore objFolder
    End If
    Next

    For Each pstName in arrNames
    set objFolder = objNS.Folders.Item(pstName)
    objNS.RemoveStore objFolder
    Next
    set objFolder = Nothing

  9. Hi Andrew

    Just discovered this script looks perfect for what I am foing. I get an error about the remote path not being writable. I see the section of code referencing this but the users home directory is writabke in that i can move files manually. Is there a change I have to make to or file I have to create on the remote path in order to get this working?

  10. Great work, ive been looking for a such a script. My vbs skills are basic, but i want a script to search a network path and then add the pst files to outlook. How can this be done?

  11. Sir,
    i have edited your script as per our domain and share setting. given all rights to that particular user. but i dont know why i am getting an error that “remote path is not writable” if i comment to this i got one more error ” you cannot close the mailbox….. that code is 80004005 and source is microsoft office outlook

  12. sebcou Comment:
    Just wondering if anyone found out how to resolve the loop issue. I am having the issue with it only handling one PST at time. Any help is very much appreciated.

    Thanks

  13. Hi Andrew, unsure if you’d still read this blog, but would it be possible to reverse the script without much issue? My scripting experience is limited, but basically what’s needed to be done is check if .pst files are mapped up on a specified network drive then copy them to a specified folder on the harddrive and map them up, so yeah, same thing but backwards 😀

  14. See a previous users comment about how networked .pst files aren’t supported.

    Microsoft says opening .pst files in outlook from a network location can cause corruption and even server hangs. If you set this up and experience any issues don’t expect any help from MS support.

    We are currently trying to move .pst files from a network location back to the local computer to avoid these issues.

  15. Uggh this script is close (http://stackoverflow.com/questions/6414189/move-pst-files-to-server-via-vb ) but what I am noticing is:
    1) Only works for one PST (I don’t care about PST’s not connected for my purposes)
    2) It seems to corrupt the copy of the PST on the destination if run when Outlook is closed. If open, it closes Outlook and moves it no issue.

    The supplement that DrNO added…where would that go in the code can you provide the full script with your piece in it?

Comments are closed.