VBScript копирует только пустой (265K) PST из сетевой папки в сетевую папку

Question

В настоящее время все пользователи подключены к своим дискам Home (Z:), мы создали (Network Share) диски P:\, чтобы пользователи могли использовать их для файлов PST. Мне поручено скопировать вложенные файлы PST (независимо от того, существуют ли они на локальном диске C: \ или в личном ресурсе пользователя Z:) в новый файл P:\, и переназначить их внешний вид. Есть 1800 пользователей, и присоединение этого сценария к объекту групповой политики является логичным способом.

Этот скрипт успешно работает для файлов PST на C:. Проблема, с которой я сталкиваюсь, заключается в том, что она копирует только пустую версию PST-файла "shell" (с тем же именем), которая прикреплена с диска Z: \ пользователя. Пустой файл PST (265 КБ) копируется на диск P:. Ниже приведен код, который я использую. Любая помощь будет высоко ценится. Спасибо.

Option Explicit
Const OverwriteExisting = True

'get username, will use later
dim objNetwork, username, LogFolder, LogFile
Dim cnt : cnt = 0
Dim counter : counter = 0
Set objNetwork = CreateObject("WScript.Network")
username = objNetwork.UserName
username = LCase(username)

LogFolder  = "c:\ProgramData\Logs\" & username
LogFile = LogFolder & "\" & "pst.txt"

'network path to write pst files to
Dim strNetworkPath : strNetworkPath = "\\NetworkShare\PST\" & username
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & 
"\" End If

'initiate variables and instantiate objects
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFolder, 
pstFiles, pstName, strPath, objShell
Set objFSO = CreateObject("Scripting.FileSystemObject")
'only run once per user, quit if log file already created from previous run
If objFSO.FileExists(LogFile) Then
    MsgBox "Script has already been run, Exiting"
WScript.Quit()
End If
Set objTextFile = objFSO.CreateTextFile("c:\ProgramData\Logs\" & username & 
"\pst.txt" , True)
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set objShell = WScript.CreateObject("Wscript.Shell")
Dim count : count = -1

'Enumerate PST files and build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
   For Each objFolder in objNS.Folders
   If GetPSTPath(objFolder.StoreID) <> "" Then
   count = count + 1
   pstFiles = GetPSTPath(objFolder.StoreID)
   pstName = objFolder.Name
   pstFolder = objFolder
   objTextFile.Write(count & "  " & pstFiles & vbCrLf)
   ReDim Preserve arrNames(count)
   arrNames(count) = pstName
   ReDim Preserve arrPaths(count)
   arrPaths(count) = pstFiles
   End If
Next
'quits if no pst files were found
If count < 0 Then
MsgBox "No PST Files Found."
Wscript.Quit()
End If

 MsgBox "PST Migration Starting. Outlook will close and re-open, Please be 
 patient."

For Each pstName in arrNames
set objFolder = objNS.Folders.Item(pstName)
objNS.RemoveStore objFolder
Next
set objFolder = Nothing

'closes the outlook session
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing



objTextFile.Write("moving them" & vbCrLf)

' copies the found pst files to the new location
Dim pstPath
For Each pstPath In arrPaths
On Error Resume Next
    objTextFile.Write(pstPath & vbCrLf)
    pstPath.Copy(strNetworkPath)
    objFSO.Copyfile pstPath, strNetworkPath
    If Err.Number <> 0 Then
        Wscript.sleep 5000
        objFSO.Copyfile pstPath, strNetworkPath
    End If
Err.Clear
On Error GoTo 0
Next
Set objFSO = Nothing

'sleep shouldn't be necessary, but was having issues believed to be related 
 to latency
wscript.sleep 5000
'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")

'Re-map Outlook folders
For Each pstPath In arrPaths
objTextFile.Write("Remapping " & pstPath & " to " & strNetworkPath & 
Mid(pstPath, InStrRev(pstPath, "\") + 1) & vbCrLf)
objNS.AddStore strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1)
Next

count = -1

For Each objFolder In objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
    count = count + 1
    objTextFile.Write("Renaming " & GetPSTPath(objFolder.StoreID) & " to " & 
arrNames(count) & vbCrLf)
    objFolder.Name = arrNames(count)
End If
Next

objOutlook.Session.Logoff
objOutlook.Quit
objTextFile.Write("Closing Outlook instance and unmapping obj references...")
Set objFolder = Nothing
Set objTextFile = Nothing
Set objOutlook = Nothing
Set objNS = Nothing
'wscript.echo "PST Migration and Remapping is Complete"
MsgBox "PST Migration and Remapping is Complete"
wscript.Quit

Private Function GetPSTPath(byVal input)
'Will return the path of all PST files
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