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