Hey folks,
before I start: yes I know PST files located on the network are a bad idea BUT we are looking to implement a vault solution, and need to consolidate all psts files in a central location.
Ok, my question!
I have found a fantastic script here http://scripts-and-bits.blogspot.com.au/ that will do most of what we need.
A few changes are required however:
- Some users may well have pst files with the same name located in different directories. The pstInfo.add pstPath,objFolder would need to amend the file name with _1, _2, _3, etc for each pst file it finds. These would need to be recorded in the array so it knows what to reconnect once copy has finished
- The script exludes empty pst file, if not isEmpty(GetPSTPath(objFolder.storeid)) then. Given users may well run the script twice it would also need to exclude the destination folder, ie the "copylocation" folder
- It would initially need to check that the destination folder / "copylocation" folder exists, and is writeable by the current user, otherwise it pops up a msg box, eg Destination not valid, contact helpdesk, then quit
I've tested it on my own account and the code below works great.
I'm completely out of my depth however trying to add the functionality as listed above.
Can anyone shed some light on where I might start or even better amend the code to include the features?
If it were SAN/VMware/IOS stuff I might have a chance.. but I'm shooting in the dark when it comes to modifying array entries, etc.
Thanks for any help you might offer!
Shane.
'script will log current open PST files 'user must be logged on for script to work 'script will then move PSTs on a network share to the local drive ' This script assumes you are running XP 'set objects On Error Resume Next Set objFSO = CreateObject("Scripting.FileSystemObject") Set objShell = WScript.CreateObject("Wscript.Shell") Set objNetwork = CreateObject("Wscript.Network") dim objNS,objOutlook, errorCounter errorCounter = 0 Call OutlookObjects strComputer = objNetwork.ComputerName 'returns computer name '''''''''' setup log files dim objTextFile, LogFolder LogFolder = "\\server\logs$\" & strComputer Call CreateLogFile 'create log file CheckLoggedOn 'checks to see if a user is logged on - exit if not logged in ****This will pick up the system account or runas account from SCCM - beware. 'setup dictionary dim pstInfo set pstInfo = createobject("scripting.Dictionary") 'setup array to store PST locations Dim pstArray() Dim counter : counter = 0 'read Outlook Data Stores For Each objFolder In objNS.Session.Folders 'all data files in outlook if not isEmpty(GetPSTPath(objFolder.storeid)) then 'filter out empty items 'wscript.echo objFolder pstPath = GetPSTPath(objFolder.storeid) 'returns the PST file path in text redim preserve pstArray(counter) pstArray(counter) = pstPath counter = counter + 1 pstInfo.add pstPath,objFolder errorDisplay ("Read Data Store") End If Next displayMsg("------- Open PST files --------") 'log all open PST files pstKeys = pstInfo.keys 'log all open psts for each key in pstKeys displayMsg(key) Next displayMsg("------- Remove Network PST --------") 'remove all open PSTs on network shares for each key in pstKeys If GetDriveType(left(key,2)) = "Network" Then 'if PST is stored on Network share.... 'wscript.echo key objNS.RemoveStore pstInfo.item(key) 'disconnect the PST - this will not delete it displayMsg("Removed " & key) errorDisplay ("Removing Store " & key) End if Next 'creating path to outlook data folder - mydocuments\outlook files 'not using special folders as this will re-direct back to the H drive. Must use a hard coded path to the C: drive. 'myDocuments = objShell.SpecialFolders("MyDocuments") 'myDocuments = "c:\documents and settings\" & objNetwork.UserName & "\ copyLocation = "c:\documents and settings\" & objNetwork.UserName & "\My Documents\Outlook Files\" 'wscript.echo copyLocation GeneratePath(copyLocation) 'create copy location if it does not exist DisplayMsg("------ Copy to: " & copyLocation & "-------") 'Quit outlook so we can move the PST Call CloseOutlook 'copy PSTs for each key in pstKeys If GetDriveType(left(key,2)) = "Network" Then 'wscript.echo "copy " & key & " to " & copyLocation fileName = objFSO.GetBaseName(key) + ".pst" 'file name only so we can compare source and destination files destinationFileName = copyLocation & fileName DisplayMsg("Copy " & key & " to " & copyLocation) objFSO.copyfile key,copyLocation 'give time for copy to complete. WARNING.....if user has large PST eg 2GB it could take several minutes to copy. errorDisplay ("Copying " & key) wscript.sleep 500 'wscript.echo ValidateCopy(key,destinationFileName) End If Next Call OutlookObjects 'add the PST files back into the store for each key in pstKeys If GetDriveType(left(key,2)) = "Network" Then 'wscript.echo ("add " & pstInfo.item(key)) fileName = objFSO.GetBaseName(key) + ".pst" destinationFileName = copyLocation & fileName 'wscript.echo "add " & destinationFileName displayMsg("Adding " & destinationFileName) objNS.AddStore destinationFileName errorDisplay ("Adding " & destinationFileName) wscript.sleep 500 End If Next objShell.run "outlook.exe" 'Mark the following for deletion in log file displayMsg("Mark the following PSTs for deletion") for each key in pstKeys If GetDriveType(left(key,2)) = "Network" Then displayMsg("DELETE-" & key) End If Next Call QuitScript 'wscript.echo "complete" ''''''''''''' FUNCTIONS AND SUBS '''''''''''''''''' Sub OutlookObjects Set objOutlook = CreateObject("Outlook.Application") Set objNS = objOutlook.GetNamespace("MAPI") wscript.sleep 3000 End Sub Sub CloseOutlook objOutlook.Session.logoff objOutlook.Quit Set objOutlook = Nothing Set objNS = Nothing WScript.Sleep 3000 'give outlook time to close KillTask("outlook.exe") 'sometimes outlook does not exit - KILL IT!!!!! End Sub Function GetPSTPath(input) 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 Function GetDriveType(input) 'returns the type of drive the PST is stored on. strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_logicaldisk") For Each objItem In colItems If objItem.driveType = "4" And objItem.deviceID = input Then 'network drive GetDriveType = "Network" ElseIf objItem.driveType = "2" And objItem.deviceID = input Then 'removable drive GetDriveType = "Removable" ElseIf objItem.driveType = "3" And objItem.deviceID = input Then 'local disk GetDriveType = "Local Disk" End If Next End Function Function KillTask(input) 'kill outlook if it is still running. If outlook is still running, it will prevent the copy of pst. strComputer = "." strProcessToKill = input SET objWMIService = GETOBJECT("winmgmts:" _ & "{impersonationLevel=impersonate}!\\" _ & strComputer & "\root\cimv2") SET colProcess = objWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & strProcessToKill & "'") count = 0 FOR EACH objProcess in colProcess objProcess.Terminate() count = count + 1 NEXT 'wscript.echo "Killed " & count & " instances of " & _ 'strProcessToKill & "on " & strComputer End Function Sub CreateLogFile 'On Error Resume Next Const ForReading = 1 Const ForWriting = 2 Const ForAppending = 8 '~~~~~~~~~~~~~~ Create Log Folder and Start Log File ~~~~~~~~~~~~~~~~~~~~~~~~~~ 'LogFolder = "\\lonlon\logs$\" & strComputer LogFile = LogFolder & "\" & "pst1.log" If objFSO.FolderExists(LogFolder) = False Then Call GeneratePath(LogFolder) End if Set objTextFile = objFSO.OpenTextFile(Logfile, ForWriting, True) 'True=create new, false=don't DisplayMsg(" - Starting Script - ") DisplayMsg(" ") DisplayMsg(" - Date: - " & Date) DisplayMsg(" - Time: - " & Time) DisplayMsg(" - Logged on User: - " & objNetwork.UserName) DisplayMsg(" ") errorDisplay ("Create Log File") End Sub Function GeneratePath(pFolderPath) GeneratePath = False If Not objFSO.FolderExists(pFolderPath) Then If GeneratePath(objFSO.GetParentFolderName(pFolderPath)) Then GeneratePath = True Call objFSO.CreateFolder(pFolderPath) End If Else GeneratePath = True End If End Function '~~~~~~~~~~~~~~ Write "DisplayMsg" variable to log file ~~~~~~~~~~~~~~ Function DisplayMsg(strMessage) If iDisplayLogFile = 1 Then WScript.Echo strMessage End If objTextFile.WriteLine strMessage End Function Function errorDisplay (desciption) If Err.Number <> 0 Then DisplayMsg(" ERROR " & description) DisplayMsg("Error number: " & err.number) DisplayMsg("Error description: " & err.description) err.clear errorCounter = errorCounter + 1 End If End Function Function GetFileSize(input) Dim File Set file = objFSO.GetFile(input) GetFileSize = file.size / 1024 End Function Function ValidateCopy(source,destination) 'need to convert this to a md5 hash operation http://www.naterice.com/articles/66 sourceFileSize = GetFileSize(source) destFileSize = GetFileSize(destination) if sourceFileSize = destFileSize Then ValidateCopy = "TRUE" displayMsg("File copy validated") Else ValidateCopy = "FALSE" displayMsg("************ WARNING - File copy operation appears to have failed") End IF End Function Function CheckLoggedOn strComputer = "." Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * From Win32_ComputerSystem") For Each objItem in colItems strUserName = objItem.UserName If IsNull(strUserName) Then displayMsg("No one logged on - Exiting Script") wscript.exit 95 Else displayMsg("User logged on - Continuing Script") End If Next End Function Sub QuitScript displayMsg("Exiting script with error code: " & errorCounter) wscript.quit errorCounter End Sub Function CheckProcess (input) set service = GetObject ("winmgmts:") 'CheckProcess = "FALSE" for each Process in Service.InstancesOf ("Win32_Process") If Process.Name = input then 'wscript.echo input & " running" CheckProcess = "TRUE" End If next End Function
- Edited by base_boot Wednesday, June 13, 2012 9:34 AM