Question

在工作中，我们已经选择了一台新的交换服务器，所以我的老板要让我到我们所有的计算机上，并手动将所有打开的PST文件移动到新服务器上的文件夹中。我出于显而易见的原因决定编写脚本会更简单。经过一些研究后，我遇到了一个这样的脚本，只需要一些调整（在http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/找到），但还有很多其他我不需要的东西（检查它是否在笔记本电脑上运行），只影响本地文件夹等），所以我将其中的主要逻辑分解为我自己的版本而没有大多数这些健全性检查。我遇到的问题是我有2个看似相同的循环迭代次数不同，这会导致问题。这就是我所拥有的

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行。具体错误是计数在第二个循环中比第一个循环增加得多，但这是因为第一个循环在迭代时变短并且丢失了最后一个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的Type Mismatch错误，所以我认为它不是存储对象所需的。有什么想法吗？

Answer 1

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

Answer 2

所以，最后让这个工作正常（或者足够接近正确）。正如Brad的评论中提到的，你应该搜索你的磁盘上的PST文件以及我在这里的内容。此方法仅影响用户在Outlook中打开的PST文件，而不影响其计算机上的所有PST文件。正如我在编辑中提到的那样，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

通过VB将PST文件移动到服务器

2 个答案: