Logon Script: Move Local PST Files To Network Share

Down­load Script: move-pst-to-network.zip

So, my bud­dy (and for­mer co-work­er) called me yes­ter­day for some help with a script he put togeth­er.  His script checked the local pro­file in Out­look for any PST files that were stored local­ly.  If it found any, it would them move them to the users home space.  We tried and tried to get the script to work prop­er­ly but it nev­er seemed to work 100%.  Being that he is a good friend and this would be use­ful at work, I decid­ed to take the work he had put in and get the thing work­ing.

Here is what the script does:

  1. Checks to see if the com­put­er is a lap­top.  If it is, the user prob­a­bly uses Out­look offline and/or over VPN so mov­ing the PST to a net­work share will be detri­men­tal to the user’s expe­ri­ence.  If you don’t care, just com­ment out lines 17-21.
  2. Checks to see if Out­look is installed and can be launched prop­er­ly.  If it can not, no sense in con­tin­u­ing the script.  It will exit.
  3. Checks to see that the tar­get (net­work) direc­to­ry exists and is writable.  If it does not exist or is not writable, the script will exit.
  4. Enu­mer­ates all the local stores and returns all the PST files.
  5. Check to see if the PST files are stored on local dri­ves.  It will exclude dri­ves that are mapped net­work dri­ves and/or remov­able media.
  6. Check if a file already exists in the tar­get direc­to­ry 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 Per­son­al Fold­ers from Out­look that matched cri­te­ria.
  8. Moves actu­al PST files to net­work share (Out­look will close to release the file lock on the PST file).
  9. Adds all the Per­son­al Fold­ers back to Out­look.

I have test­ed this on Win­dows XP w/ Office 2007 and Office 2003.  I am inter­est­ed in hear­ing if this works or not in your envi­ron­ment.  I hope you find this use­ful.

'==========================================================================
' 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 look­ing for some­thing like this to do exact­ly the same thing on our net­work.

    I’ve made a few changes, so that it will work exact­ly how we want and also cre­ate a log file of what’s hap­pened. The script works great, apart from one impor­tant thing that I’m stuck on..

    It will move only the first PST it comes across in Out­look each time it is run. It does­n’t seem to either want to read the oth­ers in to the array or read oth­ers from the array.

    My VBS skills are real­ly weak (although get­ting bet­ter quick­ly!). I won­dered if you could shed any light on this?

    Many thanks, and well done on a great script!

    Mark.

    1. Hi Mark,
      We too expe­ri­enced sim­i­lar issues. How­ev­er, we rewrote our orig­i­nal script and end­ed up with the one above which has­n’t giv­en us the same grief as the orig­i­nal 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 paus­es. It seems to make a world of dif­fer­ence. We found the issue seemed to be relat­ed to laten­cy either on the sys­tem or on the net­work. Putting in more paus­es fixed the issue (see line 98). Try adding a pause on line 105 and/or line 85.

  2. Hi Andrew,

    Your vbscript is amaz­ing!

    I’m hav­ing a slight issue with Out­look 2007. Cur­rent­ly, all of our work­sta­tions have the “Per­son­al Fold­ers” as the default mail fold­er in which all emails flow into. When­ev­er I run your script up to line 75 ( objOutlook.Session.RemoveStore obj­Fold­er), I get the fol­low­ing error mes­sage:

    You can­not close the mail­box that con­tains your cal­en­dar, con­tacts, and inbox.

    Is there are way to force removal of that “Per­son­al Fold­ers”?

    I real­ly appre­ci­ate your help!
    Thank you very much,
    Bao Tran

    1. Hi Andrew,
      I am hav­ing the same issue as the Microsoft Guy.
      the prob­lem hap­pens when you try to move a PST file that is already the default mail fold­er.
      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 mount­ed in Out­look. When you remove the fold­er in the For Each loop, the col­lec­tion of objNS.Folders is mod­i­fied (the fold­er object is removed from the col­lec­tion) and it caus­es the loop to stop. It results in the sec­ond PST not being moved.

    To solve this prob­lem, I had to put the fold­er in anoth­er array instead of remov­ing it in the For Each loop then loop through this array and remove the fold­er from Out­look. I can send you my ver­sion of the code if you want.

    Many thanks for your script.

    1. Hi Seb­cou,

      How can i get your ver­sion of the script, i’m hav­ing the same issues your hav­ing

      Thank you

  4. Hi Seb­cou,

    How can i get your ver­sion of the script, i’m hav­ing the same issues your hav­ing

    Thank you

  5. Hel­lo,

    in my case the script in here:
    if (str­Chas­sisType >= 8 And str­Chas­sisType <=12) Or (str­Chas­sisType = 14) Then

    Actu­al­ly I am look­ing for a script to place back .pst files from net­work share to user pro­file.
    Can you help me with that?
    You script is amaz­ing but I have some prob­lems with it.

    Regards,
    Peter

  6. Hi seb­cou,

    I’m also inter­es­set­ed in your ver­sion of this great script. I’m expe­ri­enc­ing the same trou­ble as you and Gui­do do.
    Could you sent me your ver­sion?

    Many thanks.

  7. Did Seb­cou ever send out his updat­ed script? Hav­ing the same prob­lem where it will only move one PST per script run. Also any­body else have a solu­tion for archive files that have the same file name?

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

    Read answer :

    ’ Enu­mer­ate PST file­sand build arrays
    objTextFile.Write(“Enumerating PST files” & vbCrLf)
    For Each obj­Fold­er in objNS.Folders
    If GetPSTPath(objFolder.StoreID) “” Then
    count = count + 1
    pst­Files = GetPSTPath(objFolder.StoreID)
    pst­Name = objFolder.Name
    pst­Fold­er = obj­Fold­er
    objTextFile.Write(count & ” ” & pst­Files & vbCrLf)
    ReD­im Pre­serve arrNames(count)
    arrNames(count) = pst­Name
    ReD­im Pre­serve arrPaths(count)
    arrPaths(count) = pst­Files
    ‘objOutlook.Session.RemoveStore obj­Fold­er
    End If
    Next

    For Each pst­Name in arrNames
    set obj­Fold­er = objNS.Folders.Item(pstName)
    objNS.RemoveStore obj­Fold­er
    Next
    set obj­Fold­er = Noth­ing

  9. Hi Andrew

    Just dis­cov­ered this script looks per­fect for what I am foing. I get an error about the remote path not being writable. I see the sec­tion of code ref­er­enc­ing this but the users home direc­to­ry is writabke in that i can move files man­u­al­ly. Is there a change I have to make to or file I have to cre­ate on the remote path in order to get this work­ing?

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

  11. Sir,
    i have edit­ed your script as per our domain and share set­ting. giv­en all rights to that par­tic­u­lar user. but i dont know why i am get­ting an error that “remote path is not writable” if i com­ment to this i got one more error ” you can­not close the mail­box.…. that code is 80004005 and source is microsoft office out­look

  12. seb­cou Com­ment:
    Just won­der­ing if any­one found out how to resolve the loop issue. I am hav­ing the issue with it only han­dling one PST at time. Any help is very much appre­ci­at­ed.

    Thanks

  13. Hi Andrew, unsure if you’d still read this blog, but would it be pos­si­ble to reverse the script with­out much issue? My script­ing expe­ri­ence is lim­it­ed, but basi­cal­ly what’s need­ed to be done is check if .pst files are mapped up on a spec­i­fied net­work dri­ve then copy them to a spec­i­fied fold­er on the hard­drive and map them up, so yeah, same thing but back­wards 😀

  14. See a pre­vi­ous users com­ment about how net­worked .pst files aren’t sup­port­ed.

    Microsoft says open­ing .pst files in out­look from a net­work loca­tion can cause cor­rup­tion and even serv­er hangs. If you set this up and expe­ri­ence any issues don’t expect any help from MS sup­port.

    We are cur­rent­ly try­ing to move .pst files from a net­work loca­tion back to the local com­put­er 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 notic­ing is:
    1) Only works for one PST (I don’t care about PST’s not con­nect­ed for my pur­pos­es)
    2) It seems to cor­rupt the copy of the PST on the des­ti­na­tion if run when Out­look is closed. If open, it clos­es Out­look and moves it no issue.

    The sup­ple­ment that DrNO added…where would that go in the code can you pro­vide the full script with your piece in it?

Comments are closed.