通過VB將PST文件移動到服務器

Question

在工作中，我們選擇了一個新的Exchange服務器，所以我的老闆會讓我轉到所有的電腦上，並手動將所有打開的PST文件移動到他們的文件夾上新的服務器。我由於顯而易見的原因決定編寫這個腳本更簡單。經過一些研究後，我發現了一個這樣的腳本，只需要稍微調整一下（在這裏找到http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/），但有很多其他的東西我不需要（檢查它是否在筆記本電腦上運行，隻影響本地文件夾等），所以我在沒有大部分這些完整性檢查的情況下，將其中的主要邏輯拆分爲我自己的版本。我遇到的問題是，我有兩個看似相同的循環迭代不同次數，並導致問題。下面是我有

Option Explicit 
Const OverwriteExisting = True 

' get username, will use later 
Dim WshNetwork: Set WshNetwork = wscript.CreateObject("WScript.Network") 
Dim user: user = LCase(WshNetwork.UserName) 
Set WshNetwork = Nothing 

' network path to write pst files to 
Dim strNetworkPath : strNetworkPath = "\\server\folder\" 
'Fix network path if forgot to include trailing slash... 
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\" End If 

' initiate variables and instantiate objects 
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFiles, pstName, strPath 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objTextFile = objFSO.CreateTextFile("c:\My\Desktop\pst_script_log.txt " , True) 
Set objOutlook = CreateObject("Outlook.Application") 
Set objNS = objOutlook.GetNamespace("MAPI") 
Dim count : count = -1 

' Enumerate PST filesand build arrays 
objTextFile.Write("Enumerating PST files" & vbCrLf) 
For Each objFolder in objNS.Folders 
    If GetPSTPath(objFolder.StoreID) <> "" Then 
     pstFiles = GetPSTPath(objFolder.StoreID) 
     pstName = objFolder.Name 
     count = count + 1 
     objTextFile.Write(count & " " & pstFiles & vbCrLf) 
     ReDim Preserve arrNames(count) 
     arrNames(count) = pstName 
     ReDim Preserve arrPaths(count) 
     arrPaths(count) = pstFiles 
     objOutlook.Session.RemoveStore objFolder 
    End IF 
Next 

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

' quits if no pst files were found 
If count < 0 Then 
    wscript.echo "No PST Files Found." 
    wscript.Quit 
End If 

objTextFile.Write("moving them" & vbCrLf) 

' moves the found pst files to the new location 
Dim pstPath 
For Each pstPath In arrPaths 
    On Error Resume Next 
     objTextFile.Write(pstPath & vbCrLf) 
     objFSO.MoveFile pstPath, strNetworkPath 
     If Err.Number <> 0 Then 
      wscript.sleep 5000 
      objFSO.MoveFile 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 "Done." 
wscript.Quit 

Private Function GetPSTPath(byVal input) 
    'Will return the path of all PST files 
    ' Took Function from: http://www.vistax64.com/vb-script/ 
    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 

有問題的迴路是線路24和81的特定錯誤是Count獲取第二環比第一增加較多，不過那是因爲第一回路短上來它迭代和錯過最後的PST文件。在我發現大部分代碼的網站上有類似問題的人說，在某些地方添加wscript.sleep函數可以幫助他們，但是我在推薦位置上沒有這樣的運氣，並且我感覺他們的問題是與我的不一樣。

我非常感謝幫助，瞭解我的代碼中出現了什麼問題，並且我很樂意提供解決其他問題的方法，這些問題我沒有看到，並且認爲有更好的方法可以做到這一點。

EDI：在對我的問題做了一些更多的研究之後，似乎通過在第24行的循環內部執行RemoveStore，我改變了objNS.Folders的值（這很合理），並且爲了避免這種情況，我應該存儲objFolder項目我需要刪除，並在另一個循環中這樣做。現在的問題是，我不知道該怎麼做，我試過

 [line 35] 
     ReDim Preserve arrFolders(count) 
     arrFolders(count) = objFolder 
    End If 
Next 

For Each objFolder in arrFolders 
    objOutlook.Session.RemoveStore objFolder 
Next 

但是我得到關於RemoveStore類型不匹配的錯誤，所以我想是不是存放需要怎樣的對象。有任何想法嗎？

Answer 1

所以，終於得到了這個工作權利（或足夠接近右）。正如Brad在評論中提到的那樣，您應該搜索您的磁盤以獲取PST文件以及我在這裏的內容。此方法僅影響用戶在Outlook中打開的PST文件，而不影響其計算機上的所有PST文件。發生了什麼事情就像我在Edit中提到的那樣，objOutlook.Session.RemoveStore正在改變objNS.Folders的值，這會破壞我的第一個For循環。你需要在你的enumartion循環之外做到這一點，否則它會打破並錯過一些（以及在重新映射它們時會錯誤標記）。此外，需要一個循環objFolder以外的地方重新定義爲MAPIFolder對象，否則試圖刪除工作示例，當你的類型不匹配的錯誤是：

' Enumerate PST filesand 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 
    'objOutlook.Session.RemoveStore objFolder 
End If 
Next 

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

Answer 2

FWIW - 連接到PST的網絡不支持。請參閱http://support.microsoft.com/kb/297019/en-us和http://blogs.technet.com/b/askperf/archive/2007/01/21/network-stored-pst-files-don-t-do-it.aspx