VBScript only copies empty (265K) PST from Network folder to Network Folder - vbscript

Question

Currently all users are mapped to their Home Z:\ drives. We have created (Network Share) P:\ drives for users to use for PST files. I am tasked with copying attached PSTs(whether they exist on the local C:\ drive or the user's personal share Z:\) to the new P:\, and remap their outlook. There are 1800 Users and attaching this script to a GPO is the logical way.
This script works successfully for the PST files on C:\. The issue I am running into, is that it only copies an empty "shell" version of the PST file (with the same name) that is attached from the user's Z:\ drive. An empty PST file (265K) is copied over to the P: drive. Below is the Code that I am running. Any assistance will be greatly Appreciated.
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