Код:

'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