Question

当前，所有用户都映射到他们的Home Z:\驱动器。我们已经创建了（网络共享）P:\驱动器，供用户使用PST文件。我的任务是将附加的PST（无论它们存在于本地C:\驱动器上还是用户的个人共享Z:\中）复制到新的P:\，并重新映射它们的外观。有1800个用户，将这个脚本附加到GPO是合乎逻辑的方式。

此脚本可成功用于C:\上的PST文件。我遇到的问题是，它仅复制从用户的Z:\驱动器附加的PST文件的空“ shell”版本（具有相同的名称）。空的PST文件（265K）被复制到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

VBScript仅将空（265K）PST从网络文件夹复制到网络文件夹

0 个答案: