Logon Script: Move Local PST Files To Network Share

'==========================================================================
' 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