Help with PST move script

[M4rkC]

Hi Everybody,

I've cobbled together this script to move users local PST files to a network drive and then re-add them in Outlook.

The main part of the script comes from

http://halfloaded.com/

written by Andrew Healey & Nate Stevenson. There's also some manipulated extracts from

http://www.computerperformance.co.uk

examples.

I've re-worked the bits I need to so that it does what I want, putting the files in the right location and outputting to a log file instead of on-screen messages and all works ok.

The only problem I have is that it will only do this to the first PST it comes across. If there's two, it does the first and then finishes without errors.

I'm very new to VBS (as in today is the first time I've looked at it), but have looked through and can't logically see a reason for it not doing it. I'm sure I'm missing something simple.

Any pointers would be very appreciated!

Here's the code (please excuse the rem'd out bits there while I am working on it):

'==========================================================================
' VBScript Source File
' LAST EDITED: 26/10/09 by Mark Chamberlain, ICT Services
' NAME: move-pst-to-network
' COMMENT: This script will move PST files mapped in Outlook to the users
'	U:\ drive in a folder called OutlookPST
' CHANGES: 
' 
'==========================================================================

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

'Create a logfile at C:\PSTlog.txt and opens it for writing
Dim fso, LogFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set LogFile = fso.CreateTextFile("c:\PSTlog.txt", TRUE)

'Determine if outlook is installed
'If IsOutlookInstalled() = False Then
'	wscript.echo "Could not launch Outlook, script stopping."
'	LogFile.WriteLine ("Error: Could not launch Outlook, 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 = "U:\OutlookPST\"
' End Configuration Section
'=========================================================================

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

'Create folder for PST's on U:\ drive
'
'Checks if U:\OutlookPST exists, if not creates it
'and writes to log file with outcome

' Set variables for folder creation
Dim objFSO2, objFolder2, objShell2, strDirectory2
strDirectory2 = "u:\OutlookPST"

' Create the File System Object
Set objFSO2 = CreateObject("Scripting.FileSystemObject")

' Checks if folder exists, reports back
If objFSO2.FolderExists(strDirectory2) Then
   Set objFolder2 = objFSO2.GetFolder(strDirectory2)
'   WScript.Echo "OutlookPST folder already created"
	Logfile.Writeline("The OutlookPST folder already exists")
Else
   Set objFolder2 = objFSO2.CreateFolder(strDirectory2)
'   WScript.Echo "Created OutlookPST folder "
	Logfile.Writeline("Created the OutlookPST folder")
End If

'Determine if network path is writable
If IsPathWritable(strNetworkPath) = False Then
'	wscript.echo "Remote path is not writable, script stopping."
	LogFile.WriteLine ("Error: Cannot write to U:\OutlookPST\")
	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 & _
				LogFile.WriteLine("Error: 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

' Writes PST path in log for each entry in array, if any
'If count >= 0 Then
'	For Each present In arrPaths
'	LogFile.WriteLine(present)
'	LogFile.WriteLine("<br/>")

' If no entries found in array, write to log and quit
if count < 0 then
'	wscript.echo "No local PST Files Found."
	LogFile.WriteLine("No local PST files found to move.")
	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)
	LogFile.Writeline("PST re-mapped in Outlook")
Next

objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
'wscript.echo "Done."
LogFile.WriteLine("Script Finished")
LogFile.WriteLine(Date)
LogFile.WriteLine(Time)
wscript.quit

'Closes the open log file, no more to write
LogFile.Close

Private Function GetPSTPath(byVal input)
	'Will return the path of all PST files
	' Took Function from: [URL unfurl="true"]http://www.vistax64.com/vb-script/[/URL]
	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}!\\.\root\cimv2")
'		Set colChassis = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")
'		
'		'Check chassis type
'		'[URL unfurl="true"]http://msdn.microsoft.com/en-us/library/aa394474%28VS.85%29.aspx[/URL]
'		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}!\\.\root\cimv2")
		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

Many thanks,

Mark.

 

[mrmovie]

while you have a handle to the outlook application closing it using some of its close methods may be cleaner than Win32_Process.Terminate. i did have some code to close excel, word and outlook neatly (saving open workbooks, emails, notes etc) but i cant find it

 

[M4rkC]

Closing it cleanly would be handy. I've found with my scipt that every now and again when it opens/closes word that it's upsetting a plug-in we use for our IPT Voicemail system.

I've tried looking for code or switches that will suppress errors but can't find it.

 

[Geates]

The reason why I had to so drastically kill the process is because the neat way (objOutlook.Session.Logoff and objOutlook.Quit) would close outlook but leave the system process still active - denying PST access. Only when the script ends and the objects are no longer does the outlook.exe process disappear. Honestly, I'd rather not use the .terminate() method - it' too violent and may lead to corruption. On the other hand, this script is meant to be run locally, so I would hope the executer would establish safe conditions before running.

-Geates

 

[M4rkC]

I've not had problems with running my script even with Outlook open when it starts, there's no file locks when it tries to move the PST's.

 

[mrmovie]

wasnt meaning to suggest the use of .Terminate is wrong in some way Geates, it definitely has its uses for stubborn users / apps etc.

 

[Geates]

I'm running Windows 7. Perhaps that has the file lock.

- Geates